X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/a38daa0ae7af623734e0abd6c4aec03bd70e1c6d..c48254fbbfb493a29def89154bd43ca6923fdf2a:/lisp/server.el diff --git a/lisp/server.el b/lisp/server.el index 997a6c4fc6..6d73bb6ee9 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -14,7 +14,7 @@ ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) +;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, @@ -75,6 +75,13 @@ ;; The global variable "server-clients" lists all the waiting clients, ;; and which files are yet to be edited for each. +;; Todo: + +;; - handle command-line-args-left. +;; - move most of the args processing and decision making from emacsclient.c +;; to here. +;; - fix up handling of the client's environment (place it in the terminal?). + ;;; Code: (eval-when-compile (require 'cl)) @@ -106,7 +113,7 @@ If set, the server accepts remote connections; otherwise it is local." :version "22.1") (put 'server-host 'risky-local-variable t) -(defcustom server-auth-dir "~/.emacs.d/server/" +(defcustom server-auth-dir (concat user-emacs-directory "server/") "Directory for server authentication files." :group 'server :type 'directory @@ -139,8 +146,7 @@ If set, the server accepts remote connections; otherwise it is local." (defvar server-clients nil "List of current server clients. -Each element is (PROC PROPERTIES...) where PROC is a process object, -and PROPERTIES is an association list of client properties.") +Each element is a process.") (defvar server-buffer-clients nil "List of client processes requesting editing of current buffer.") @@ -164,6 +170,7 @@ Only programs can do so." :match (lambda (widget value) (not (functionp value))) nil) + (function-item :tag "Display in new frame" switch-to-buffer-other-frame) (function-item :tag "Use pop-to-buffer" pop-to-buffer) (function :tag "Other function"))) @@ -177,10 +184,10 @@ invoke the Emacs server." (defcustom server-kill-new-buffers t "Whether to kill buffers when done with them. If non-nil, kill a buffer unless it already existed before editing -it with Emacs server. If nil, kill only buffers as specified by +it with the Emacs server. If nil, kill only buffers as specified by `server-temp-file-regexp'. -Please note that only buffers are killed that still have a client, -i.e. buffers visited which \"emacsclient --no-wait\" are never killed in +Please note that only buffers that still have a client are killed, +i.e. buffers visited with \"emacsclient --no-wait\" are never killed in this way." :group 'server :type 'boolean @@ -201,65 +208,17 @@ are done with it in the server.") "The directory in which to place the server socket. Initialized by `server-start'.") -(defun server-client (proc) - "Return the Emacs client corresponding to PROC. -PROC must be a process object. -The car of the result is PROC; the cdr is an association list. -See `server-client-get' and `server-client-set'." - (assq proc server-clients)) - -(defun server-client-get (client property) - "Get the value of PROPERTY in CLIENT. -CLIENT may be a process object, or a client returned by `server-client'. -Return nil if CLIENT has no such property." - (or (listp client) (setq client (server-client client))) - (cdr (assq property (cdr client)))) - -(defun server-client-set (client property value) - "Set the PROPERTY to VALUE in CLIENT, and return VALUE. -CLIENT may be a process object, or a client returned by `server-client'." - (let (p proc) - (if (listp client) - (setq proc (car client)) - (setq proc client - client (server-client client))) - (setq p (assq property client)) - (cond - (p (setcdr p value)) - (client (setcdr client (cons (cons property value) (cdr client)))) - (t (setq server-clients - `((,proc (,property . ,value)) . ,server-clients)))) - value)) - (defun server-clients-with (property value) "Return a list of clients with PROPERTY set to VALUE." (let (result) - (dolist (client server-clients result) - (when (equal value (server-client-get client property)) - (setq result (cons (car client) result)))))) + (dolist (proc server-clients result) + (when (equal value (process-get proc property)) + (push proc result))))) (defun server-add-client (proc) "Create a client for process PROC, if it doesn't already have one. New clients have no properties." - (unless (server-client proc) - (setq server-clients (cons (cons proc nil) - server-clients)))) - -(defun server-getenv-from (env variable) - "Get the value of VARIABLE in ENV. -VARIABLE should be a string. Value is nil if VARIABLE is -undefined in ENV. Otherwise, value is a string. - -ENV should be in the same format as `process-environment'." - (let (entry result) - (while (and env (null result)) - (setq entry (car env) - env (cdr env)) - (if (and (> (length entry) (length variable)) - (eq ?= (aref entry (length variable))) - (equal variable (substring entry 0 (length variable)))) - (setq result (substring entry (+ (length variable) 1))))) - result)) + (add-to-list 'server-clients proc)) (defmacro server-with-environment (env vars &rest body) "Evaluate BODY with environment variables VARS set to those in ENV. @@ -268,34 +227,26 @@ The environment variables are then restored to their previous values. VARS should be a list of strings. ENV should be in the same format as `process-environment'." (declare (indent 2)) - (let ((old-env (make-symbol "old-env")) - (var (make-symbol "var")) - (value (make-symbol "value")) - (pair (make-symbol "pair"))) - `(let ((,old-env process-environment)) + (let ((var (make-symbol "var")) + (value (make-symbol "value"))) + `(let ((process-environment process-environment)) (dolist (,var ,vars) - (let ((,value (server-getenv-from ,env ,var))) - (setq process-environment - (cons (if (null ,value) - ,var - (concat ,var "=" ,value)) - process-environment)))) - (unwind-protect - (progn ,@body) - (setq process-environment ,old-env))))) - -(defun server-delete-client (client &optional noframe) - "Delete CLIENT, including its buffers, terminals and frames. + (let ((,value (getenv-internal ,var ,env))) + (push (if (null ,value) + ,var + (concat ,var "=" ,value)) + process-environment))) + (progn ,@body)))) + +(defun server-delete-client (proc &optional noframe) + "Delete PROC, including its buffers, terminals and frames. If NOFRAME is non-nil, let the frames live. (To be used from `delete-frame-functions'.)" (server-log (concat "server-delete-client" (if noframe " noframe")) - client) + proc) ;; Force a new lookup of client (prevents infinite recursion). - (setq client (server-client - (if (listp client) (car client) client))) - (let ((proc (car client)) - (buffers (server-client-get client 'buffers))) - (when client + (when (memq proc server-clients) + (let ((buffers (process-get proc 'buffers))) ;; Kill the client's buffers. (dolist (buf buffers) @@ -327,23 +278,23 @@ If NOFRAME is non-nil, let the frames live. (To be used from (set-frame-parameter frame 'client nil) (delete-frame frame)))) - (setq server-clients (delq client server-clients)) + (setq server-clients (delq proc server-clients)) ;; Delete the client's tty. - (let ((terminal (server-client-get client 'terminal))) - (when (eq (terminal-live-p terminal) t) + (let ((terminal (process-get proc 'terminal))) + ;; Only delete the terminal if it is non-nil. + (when (and terminal (eq (terminal-live-p terminal) t)) (delete-terminal terminal))) ;; Delete the client's process. - (if (eq (process-status (car client)) 'open) - (delete-process (car client))) + (if (eq (process-status proc) 'open) + (delete-process proc)) (server-log "Deleted" proc)))) (defun server-log (string &optional client) "If a *server* buffer exists, write STRING to it for logging purposes. -If CLIENT is non-nil, add a description of it to the logged -message." +If CLIENT is non-nil, add a description of it to the logged message." (when (get-buffer "*server*") (with-current-buffer "*server*" (goto-char (point-max)) @@ -371,6 +322,49 @@ message." (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc) (server-delete-client proc)) +(defun server-select-display (display) + ;; If the current frame is on `display' we're all set. + ;; Similarly if we are unable to open a frames on other displays, there's + ;; nothing more we can do. + (unless (or (not (fboundp 'make-frame-on-display)) + (equal (frame-parameter (selected-frame) 'display) display)) + ;; Otherwise, look for an existing frame there and select it. + (dolist (frame (frame-list)) + (when (equal (frame-parameter frame 'display) display) + (select-frame frame))) + ;; If there's no frame on that display yet, create and select one. + (unless (equal (frame-parameter (selected-frame) 'display) display) + (let* ((buffer (generate-new-buffer " *server-dummy*")) + (frame (make-frame-on-display + display + ;; Make it display (and remember) some dummy buffer, so + ;; we can detect later if the frame is in use or not. + `((server-dummmy-buffer . ,buffer) + ;; This frame may be deleted later (see + ;; server-unselect-display) so we want it to be as + ;; unobtrusive as possible. + (visibility . nil))))) + (select-frame frame) + (set-window-buffer (selected-window) buffer) + frame)))) + +(defun server-unselect-display (frame) + (when (frame-live-p frame) + ;; If the temporary frame is in use (displays something real), make it + ;; visible. If not (which can happen if the user's customizations call + ;; pop-to-buffer etc.), delete it to avoid preserving the connection after + ;; the last real frame is deleted. + (if (and (eq (frame-first-window frame) + (next-window (frame-first-window frame) 'nomini)) + (eq (window-buffer (frame-first-window frame)) + (frame-parameter frame 'server-dummy-buffer))) + ;; The temp frame still only shows one buffer, and that is the + ;; internal temp buffer. + (delete-frame frame) + (set-frame-parameter frame 'visibility t)) + (kill-buffer (frame-parameter frame 'server-dummy-buffer)) + (set-frame-parameter frame 'server-dummy-buffer nil))) + (defun server-handle-delete-frame (frame) "Delete the client connection when the emacsclient frame is deleted." (let ((proc (frame-parameter frame 'client))) @@ -391,7 +385,8 @@ message." (server-log (format "server-handle-suspend-tty, terminal %s" terminal) proc) (condition-case err (server-send-string proc "-suspend \n") - (file-error (condition-case nil (server-delete-client proc) (error nil)))))) + (file-error ;The pipe/socket was closed. + (ignore-errors (server-delete-client proc)))))) (defun server-unquote-arg (arg) "Remove &-quotation from ARG. @@ -512,11 +507,11 @@ kill any existing server communications subprocess." (when server-use-tcp (let ((auth-key (loop - ;; The auth key is a 64-byte string of random chars in the - ;; range `!'..`~'. - for i below 64 - collect (+ 33 (random 94)) into auth - finally return (concat auth)))) + ;; The auth key is a 64-byte string of random chars in the + ;; range `!'..`~'. + for i below 64 + collect (+ 33 (random 94)) into auth + finally return (concat auth)))) (process-put server-process :auth-key auth-key) (with-temp-file server-file (set-buffer-multibyte nil) @@ -526,6 +521,21 @@ kill any existing server communications subprocess." " " (int-to-string (emacs-pid)) "\n" auth-key))))))))) +(defun server-running-p (&optional name) + "Test whether server NAME is running." + (interactive + (list (if current-prefix-arg + (read-string "Server name: " nil nil server-name)))) + (unless name (setq name server-name)) + (condition-case nil + (progn + (delete-process + (make-network-process + :name "server-client-test" :family 'local :server nil :noquery t + :service (expand-file-name name server-socket-dir))) + t) + (file-error nil))) + ;;;###autoload (define-minor-mode server-mode "Toggle Server mode. @@ -539,6 +549,131 @@ Server mode runs a process that accepts commands from the ;; nothing if there is one (for multiple Emacs sessions)? (server-start (not server-mode))) +(defun server-eval-and-print (expr proc) + "Eval EXPR and send the result back to client PROC." + (let ((v (eval (car (read-from-string expr))))) + (when (and v proc) + (with-temp-buffer + (let ((standard-output (current-buffer))) + (pp v) + (let ((text (buffer-substring-no-properties + (point-min) (point-max)))) + (server-send-string + proc (format "-print %s\n" + (server-quote-arg text))))))))) + +(defun server-create-tty-frame (tty type proc) + (add-to-list 'frame-inherited-parameters 'client) + (let ((frame + (server-with-environment (process-get proc 'env) + '("LANG" "LC_CTYPE" "LC_ALL" + ;; For tgetent(3); list according to ncurses(3). + "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES" + "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING" + "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO" + "TERMINFO_DIRS" "TERMPATH" + ;; rxvt wants these + "COLORFGBG" "COLORTERM") + (make-frame-on-tty tty type + ;; Ignore nowait here; we always need to + ;; clean up opened ttys when the client dies. + `((client . ,proc) + ;; This is a leftover from an earlier + ;; attempt at making it possible for process + ;; run in the server process to use the + ;; environment of the client process. + ;; It has no effect now and to make it work + ;; we'd need to decide how to make + ;; process-environment interact with client + ;; envvars, and then to change the + ;; C functions `child_setup' and + ;; `getenv_internal' accordingly. + (environment . ,(process-get proc 'env))))))) + + ;; ttys don't use the `display' parameter, but callproc.c does to set + ;; the DISPLAY environment on subprocesses. + (set-frame-parameter frame 'display + (getenv-internal "DISPLAY" (process-get proc 'env))) + (select-frame frame) + (process-put proc 'frame frame) + (process-put proc 'terminal (frame-terminal frame)) + + ;; Display *scratch* by default. + (switch-to-buffer (get-buffer-create "*scratch*") 'norecord) + + ;; Reply with our pid. + (server-send-string proc (concat "-emacs-pid " + (number-to-string (emacs-pid)) "\n")) + frame)) + +(defun server-create-window-system-frame (display nowait proc) + (add-to-list 'frame-inherited-parameters 'client) + (if (not (fboundp 'make-frame-on-display)) + (progn + ;; This emacs does not support X. + (server-log "Window system unsupported" proc) + (server-send-string proc "-window-system-unsupported \n") + nil) + ;; Flag frame as client-created, but use a dummy client. + ;; This will prevent the frame from being deleted when + ;; emacsclient quits while also preventing + ;; `server-save-buffers-kill-terminal' from unexpectedly + ;; killing emacs on that frame. + (let* ((params `((client . ,(if nowait 'nowait proc)) + ;; This is a leftover, see above. + (environment . ,(process-get proc 'env)))) + (frame (make-frame-on-display + (or display + (frame-parameter nil 'display) + (getenv "DISPLAY") + (error "Please specify display")) + params))) + (server-log (format "%s created" frame) proc) + ;; XXX We need to ensure the parameters are really set because Emacs + ;; forgets unhandled initialization parameters for X frames at + ;; the moment. + (modify-frame-parameters frame params) + (select-frame frame) + (process-put proc 'frame frame) + (process-put proc 'terminal (frame-terminal frame)) + + ;; Display *scratch* by default. + (switch-to-buffer (get-buffer-create "*scratch*") 'norecord) + frame))) + + +(defun server-goto-toplevel (proc) + (condition-case nil + ;; If we're running isearch, we must abort it to allow Emacs to + ;; display the buffer and switch to it. + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (bound-and-true-p isearch-mode) + (isearch-cancel)))) + ;; Signaled by isearch-cancel. + (quit (message nil))) + (when (> (recursion-depth) 0) + ;; We're inside a minibuffer already, so if the emacs-client is trying + ;; to open a frame on a new display, we might end up with an unusable + ;; frame because input from that display will be blocked (until exiting + ;; the minibuffer). Better exit this minibuffer right away. + ;; Similarly with recursive-edits such as the splash screen. + (run-with-timer 0 nil (lexical-let ((proc proc)) + (lambda () (server-execute-continuation proc)))) + (top-level))) + +;; We use various special properties on process objects: +;; - `env' stores the info about the environment of the emacsclient process. +;; - `continuation' is a no-arg function that we need to execute. It contains +;; commands we wanted to execute in some earlier invocation of the process +;; filter but that we somehow were unable to process at that time +;; (e.g. because we first need to throw to the toplevel). + +(defun server-execute-continuation (proc) + (let ((continuation (process-get proc 'continuation))) + (process-put proc 'continuation nil) + (if continuation (ignore-errors (funcall continuation))))) + (defun* server-process-filter (proc string) "Process a request from the server to edit some files. PROC is the server process. STRING consists of a sequence of @@ -550,27 +685,18 @@ To illustrate the protocol, here is an example command that emacsclient sends to create a new X frame (note that the whole sequence is sent on a single line): - -version 21.3.50 xterm -env HOME /home/lorentey -env DISPLAY :0.0 ... lots of other -env commands -display :0.0 -window-system -The server normally sends back the single command `-good-version' -as a response. - The following commands are accepted by the server: `-auth AUTH-STRING' Authenticate the client using the secret authentication string AUTH-STRING. -`-version CLIENT-VERSION' - Check version numbers between server and client, and signal an - error if there is a mismatch. The server replies with - `-good-version' to confirm the match. - `-env NAME=VALUE' An environment variable on the client side. @@ -610,7 +736,7 @@ The following commands are accepted by the server: on this tty until it gets a -resume command. `-resume' - Resume this tty frame. The client sends this string when it + Resume this tty frame. The client sends this string when it gets the SIGCONT signal and it is the foreground process on its controlling tty. @@ -621,17 +747,13 @@ The following commands are accepted by the server: The following commands are accepted by the client: -`-good-version' - Signals a version match between the client and the server. - `-emacs-pid PID' Describes the process id of the Emacs process; used to forward window change signals to it. `-window-system-unsupported' - Signals that the server does not - support creating X frames; the client must try again with a tty - frame. + Signals that the server does not support creating X frames; + the client must try again with a tty frame. `-print STRING' Print STRING on stdout. Used to send values @@ -641,8 +763,8 @@ The following commands are accepted by the client: Signal an error (but continue processing). `-suspend' - Suspend this terminal, i.e., stop the client process. Sent - when the user presses C-z." + Suspend this terminal, i.e., stop the client process. + Sent when the user presses C-z." (server-log (concat "Received " string) proc) ;; First things first: let's check the authentication (unless (process-get proc :authenticated) @@ -658,26 +780,6 @@ The following commands are accepted by the client: (delete-process proc) ;; We return immediately (return-from server-process-filter))) - (when (> (recursion-depth) 0) - ;; We're inside a minibuffer already, so if the emacs-client is trying - ;; to open a frame on a new display, we might end up with an unusable - ;; frame because input from that display will be blocked (until exiting - ;; the minibuffer). Better exit this minibuffer right away. - ;; Similarly with recursive-edits such as the splash screen. - (process-put proc :previous-string string) - (run-with-timer 0 nil (lexical-let ((proc proc)) - (lambda () (server-process-filter proc "")))) - (top-level)) - (condition-case nil - ;; If we're running isearch, we must abort it to allow Emacs to - ;; display the buffer and switch to it. - (mapc #'(lambda (buffer) - (with-current-buffer buffer - (when (bound-and-true-p isearch-mode) - (isearch-cancel)))) - (buffer-list)) - ;; Signaled by isearch-cancel - (quit (message nil))) (let ((prev (process-get proc 'previous-string))) (when prev (setq string (concat prev string)) @@ -685,190 +787,127 @@ The following commands are accepted by the client: (condition-case err (progn (server-add-client proc) - ;; If the input is multiple lines, - ;; process each line individually. - (while (string-match "\n" string) + (if (not (string-match "\n" string)) + ;; Save for later any partial line that remains. + (when (> (length string) 0) + (process-put proc 'previous-string string)) + + ;; In earlier versions of server.el (where we used an `emacsserver' + ;; process), there could be multiple lines. Nowadays this is not + ;; supported any more. + (assert (eq (match-end 0) (length string))) (let ((request (substring string 0 (match-beginning 0))) (coding-system (and default-enable-multibyte-characters (or file-name-coding-system default-file-name-coding-system))) - (client (server-client proc)) - current-frame nowait ; t if emacsclient does not want to wait for us. frame ; The frame that was opened for the client (if any). display ; Open the frame on this display. dontkill ; t if the client should not be killed. - env + (commands ()) dir + (tty-name nil) ;nil, `window-system', or the tty name. + tty-type ;string. (files nil) (lineno 1) (columnno 0)) ;; Remove this line from STRING. (setq string (substring string (match-end 0))) (while (string-match " *[^ ]* " request) - (let ((arg (substring request (match-beginning 0) (1- (match-end 0))))) + (let ((arg (substring request (match-beginning 0) + (1- (match-end 0))))) (setq request (substring request (match-end 0))) (cond - ;; -version CLIENT-VERSION: - ;; Check version numbers, signal an error if there is a mismatch. - ((and (equal "-version" arg) - (string-match "\\([0-9.]+\\) " request)) - (let* ((client-version (match-string 1 request)) - (truncated-emacs-version - (substring emacs-version 0 (length client-version)))) - (setq request (substring request (match-end 0))) - (if (equal client-version truncated-emacs-version) - (progn - (server-send-string proc "-good-version \n") - (server-client-set client 'version client-version)) - (error (concat "Version mismatch: Emacs is " - truncated-emacs-version - ", emacsclient is " client-version))))) + ;; -version CLIENT-VERSION: obsolete at birth. + ((and (equal "-version" arg) (string-match "[^ ]+ " request)) + (setq request (substring request (match-end 0)))) ;; -nowait: Emacsclient won't wait for a result. ((equal "-nowait" arg) (setq nowait t)) ;; -current-frame: Don't create frames. - ((equal "-current-frame" arg) (setq current-frame t)) + ((equal "-current-frame" arg) (setq tty-name nil)) ;; -display DISPLAY: ;; Open X frames on the given display instead of the default. - ((and (equal "-display" arg) (string-match "\\([^ ]*\\) " request)) - (setq display (match-string 1 request) - request (substring request (match-end 0)))) + ((and (equal "-display" arg) + (string-match "\\([^ ]*\\) " request)) + (setq display (match-string 1 request)) + (setq request (substring request (match-end 0)))) ;; -window-system: Open a new X frame. ((equal "-window-system" arg) - (unless (server-client-get client 'version) - (error "Protocol error; make sure to use the correct version of emacsclient")) - (unless current-frame - (if (fboundp 'x-create-frame) - (let ((params (if nowait - ;; Flag frame as client-created, but use a dummy client. - ;; This will prevent the frame from being deleted when - ;; emacsclient quits while also preventing - ;; `server-save-buffers-kill-terminal' from unexpectedly - ;; killing emacs on that frame. - (list (cons 'client 'nowait) (cons 'environment env)) - (list (cons 'client proc) (cons 'environment env))))) - (setq frame (make-frame-on-display - (or display - (frame-parameter nil 'display) - (getenv "DISPLAY") - (error "Please specify display")) - params)) - (server-log (format "%s created" frame) proc) - ;; XXX We need to ensure the parameters are - ;; really set because Emacs forgets unhandled - ;; initialization parameters for X frames at - ;; the moment. - (modify-frame-parameters frame params) - (select-frame frame) - (server-client-set client 'frame frame) - (server-client-set client 'terminal (frame-terminal frame)) - - ;; Display *scratch* by default. - (switch-to-buffer (get-buffer-create "*scratch*") 'norecord) - - (setq dontkill t)) - ;; This emacs does not support X. - (server-log "Window system unsupported" proc) - (server-send-string proc "-window-system-unsupported \n") - (setq dontkill t)))) + (setq dontkill t) + (setq tty-name 'window-system)) ;; -resume: Resume a suspended tty frame. ((equal "-resume" arg) - (let ((terminal (server-client-get client 'terminal))) + (lexical-let ((terminal (process-get proc 'terminal))) (setq dontkill t) - (when (eq (terminal-live-p terminal) t) - (resume-tty terminal)))) + (push (lambda () + (when (eq (terminal-live-p terminal) t) + (resume-tty terminal))) + commands))) ;; -suspend: Suspend the client's frame. (In case we ;; get out of sync, and a C-z sends a SIGTSTP to ;; emacsclient.) ((equal "-suspend" arg) - (let ((terminal (server-client-get client 'terminal))) + (lexical-let ((terminal (process-get proc 'terminal))) (setq dontkill t) - (when (eq (terminal-live-p terminal) t) - (suspend-tty terminal)))) + (push (lambda () + (when (eq (terminal-live-p terminal) t) + (suspend-tty terminal))) + commands))) ;; -ignore COMMENT: Noop; useful for debugging emacsclient. ;; (The given comment appears in the server log.) - ((and (equal "-ignore" arg) (string-match "\\([^ ]*\\) " request)) + ((and (equal "-ignore" arg) (string-match "[^ ]* " request)) (setq dontkill t request (substring request (match-end 0)))) ;; -tty DEVICE-NAME TYPE: Open a new tty frame at the client. - ((and (equal "-tty" arg) (string-match "\\([^ ]*\\) \\([^ ]*\\) " request)) - (let ((tty (server-unquote-arg (match-string 1 request))) - (type (server-unquote-arg (match-string 2 request)))) - (setq request (substring request (match-end 0))) - (unless (server-client-get client 'version) - (error "Protocol error; make sure you use the correct version of emacsclient")) - (unless current-frame - (server-with-environment env - '("LANG" "LC_CTYPE" "LC_ALL" - ;; For tgetent(3); list according to ncurses(3). - "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES" - "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING" - "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO" - "TERMINFO_DIRS" "TERMPATH") - (setq frame (make-frame-on-tty tty type - ;; Ignore nowait here; we always need to clean - ;; up opened ttys when the client dies. - `((client . ,proc) - (environment . ,env))))) - (select-frame frame) - (server-client-set client 'frame frame) - (server-client-set client 'tty (terminal-name frame)) - (server-client-set client 'terminal (frame-terminal frame)) - - ;; Display *scratch* by default. - (switch-to-buffer (get-buffer-create "*scratch*") 'norecord) - - ;; Reply with our pid. - (server-send-string proc (concat "-emacs-pid " (number-to-string (emacs-pid)) "\n")) - (setq dontkill t)))) - - ;; -position LINE: Go to the given line in the next file. - ((and (equal "-position" arg) (string-match "\\(\\+[0-9]+\\) " request)) - (setq lineno (string-to-number (substring (match-string 1 request) 1)) - request (substring request (match-end 0)))) - - ;; -position LINE:COLUMN: Set point to the given position in the next file. - ((and (equal "-position" arg) (string-match "\\+\\([0-9]+\\):\\([0-9]+\\) " request)) + ((and (equal "-tty" arg) + (string-match "\\([^ ]*\\) \\([^ ]*\\) " request)) + (setq tty-name (match-string 1 request)) + (setq tty-type (match-string 2 request)) + (setq dontkill t) + (setq request (substring request (match-end 0)))) + + ;; -position LINE[:COLUMN]: Set point to the given + ;; position in the next file. + ((and (equal "-position" arg) + (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)? " + request)) (setq lineno (string-to-number (match-string 1 request)) - columnno (string-to-number (match-string 2 request)) + columnno (if (null (match-end 2)) 0 + (string-to-number (match-string 2 request))) request (substring request (match-end 0)))) ;; -file FILENAME: Load the given file. - ((and (equal "-file" arg) (string-match "\\([^ ]+\\) " request)) + ((and (equal "-file" arg) + (string-match "\\([^ ]+\\) " request)) (let ((file (server-unquote-arg (match-string 1 request)))) (setq request (substring request (match-end 0))) (if coding-system (setq file (decode-coding-string file coding-system))) (setq file (command-line-normalize-file-name file)) (push (list file lineno columnno) files) - (server-log (format "New file: %s (%d:%d)" file lineno columnno) proc)) + (server-log (format "New file: %s (%d:%d)" + file lineno columnno) proc)) (setq lineno 1 columnno 0)) ;; -eval EXPR: Evaluate a Lisp expression. - ((and (equal "-eval" arg) (string-match "\\([^ ]+\\) " request)) - (let ((expr (server-unquote-arg (match-string 1 request)))) + ((and (equal "-eval" arg) + (string-match "\\([^ ]+\\) " request)) + (lexical-let ((expr (server-unquote-arg + (match-string 1 request)))) (setq request (substring request (match-end 0))) (if coding-system (setq expr (decode-coding-string expr coding-system))) - (let ((v (eval (car (read-from-string expr))))) - (when (and (not frame) v) - (with-temp-buffer - (let ((standard-output (current-buffer))) - (pp v) - (server-send-string - proc (format "-print %s\n" - (server-quote-arg - (buffer-substring-no-properties (point-min) - (point-max))))))))) + (push (lambda () (server-eval-and-print expr proc)) + commands) (setq lineno 1 columnno 0))) @@ -877,7 +916,8 @@ The following commands are accepted by the client: (let ((var (server-unquote-arg (match-string 1 request)))) ;; XXX Variables should be encoded as in getenv/setenv. (setq request (substring request (match-end 0))) - (setq env (cons var env)))) + (process-put proc 'env + (cons var (process-get proc 'env))))) ;; -dir DIRNAME: The cwd of the emacsclient process. ((and (equal "-dir" arg) (string-match "\\([^ ]+\\) " request)) @@ -890,59 +930,75 @@ The following commands are accepted by the client: ;; Unknown command. (t (error "Unknown command: %s" arg))))) - (let (buffers) - (when files - (run-hooks 'pre-command-hook) - (setq buffers (server-visit-files files client nowait)) - (run-hooks 'post-command-hook)) - - (when frame - (with-selected-frame frame - (display-startup-echo-area-message) - (unless inhibit-splash-screen - (condition-case err - ;; This looks scary because `fancy-splash-screens' - ;; will call `recursive-edit' from a process filter. - ;; However, that should be safe to do now. - (display-splash-screen t) - ;; `recursive-edit' will throw an error if Emacs is - ;; already doing a recursive edit elsewhere. Catch it - ;; here so that we can finish normally. - (error nil))))) - - ;; Delete the client if necessary. - (cond - (nowait - ;; Client requested nowait; return immediately. - (server-log "Close nowait client" proc) - (server-delete-client proc)) - ((and (not dontkill) (null buffers)) - ;; This client is empty; get rid of it immediately. - (server-log "Close empty client" proc) - (server-delete-client proc))) - (cond - ((or isearch-mode (minibufferp)) - nil) - ((and frame (null buffers)) - (message "%s" (substitute-command-keys - "When done with this frame, type \\[delete-frame]"))) - ((not (null buffers)) - (server-switch-buffer (car buffers)) - (run-hooks 'server-switch-hook) - (unless nowait - (message "%s" (substitute-command-keys - "When done with a buffer, type \\[server-edit]")))))))) - - ;; Save for later any partial line that remains. - (when (> (length string) 0) - (process-put proc 'previous-string string))) + (setq frame + (case tty-name + ((nil) (if display (server-select-display display))) + ((window-system) + (server-create-window-system-frame display nowait proc)) + (t (server-create-tty-frame tty-name tty-type proc)))) + + (process-put proc 'continuation + (lexical-let ((proc proc) + (files files) + (nowait nowait) + (commands commands) + (dontkill dontkill) + (frame frame) + (tty-name tty-name)) + (lambda () + (server-execute proc files nowait commands + dontkill frame tty-name)))) + + (when (or frame files) + (server-goto-toplevel proc)) + + (server-execute-continuation proc)))) ;; condition-case - (error (ignore-errors - (server-send-string - proc (concat "-error " (server-quote-arg (error-message-string err)))) - (setq string "") - (server-log (error-message-string err) proc) - (delete-process proc))))) + (error (server-return-error proc err)))) + +(defun server-execute (proc files nowait commands dontkill frame tty-name) + (condition-case err + (let* ((buffers + (when files + (run-hooks 'pre-command-hook) + (prog1 (server-visit-files files proc nowait) + (run-hooks 'post-command-hook))))) + + (mapc 'funcall (nreverse commands)) + + ;; Delete the client if necessary. + (cond + (nowait + ;; Client requested nowait; return immediately. + (server-log "Close nowait client" proc) + (server-delete-client proc)) + ((and (not dontkill) (null buffers)) + ;; This client is empty; get rid of it immediately. + (server-log "Close empty client" proc) + (server-delete-client proc))) + (cond + ((or isearch-mode (minibufferp)) + nil) + ((and frame (null buffers)) + (message "%s" (substitute-command-keys + "When done with this frame, type \\[delete-frame]"))) + ((not (null buffers)) + (server-switch-buffer (car buffers)) + (run-hooks 'server-switch-hook) + (unless nowait + (message "%s" (substitute-command-keys + "When done with a buffer, type \\[server-edit]"))))) + (when (and frame (null tty-name)) + (server-unselect-display frame))) + (error (server-return-error proc err)))) + +(defun server-return-error (proc err) + (ignore-errors + (server-send-string + proc (concat "-error " (server-quote-arg + (error-message-string err)))) + (server-log (error-message-string err) proc) + (delete-process proc))) (defun server-goto-line-column (file-line-col) "Move point to the position indicated in FILE-LINE-COL. @@ -950,13 +1006,13 @@ FILE-LINE-COL should be a three-element list as described in `server-visit-files'." (goto-line (nth 1 file-line-col)) (let ((column-number (nth 2 file-line-col))) - (if (> column-number 0) - (move-to-column (1- column-number))))) + (when (> column-number 0) + (move-to-column (1- column-number))))) -(defun server-visit-files (files client &optional nowait) +(defun server-visit-files (files proc &optional nowait) "Find FILES and return a list of buffers created. FILES is an alist whose elements are (FILENAME LINENUMBER COLUMNNUMBER). -CLIENT is the client that requested this operation. +PROC is the client that requested this operation. NOWAIT non-nil means this client is not waiting for the results, so don't mark these buffers specially, just visit them normally." ;; Bind last-nonmenu-event to force use of keyboard, not mouse, for queries. @@ -993,12 +1049,11 @@ so don't mark these buffers specially, just visit them normally." (unless nowait ;; When the buffer is killed, inform the clients. (add-hook 'kill-buffer-hook 'server-kill-buffer nil t) - (push (car client) server-buffer-clients)) + (push proc server-buffer-clients)) (push (current-buffer) client-record))) (unless nowait - (server-client-set - client 'buffers - (nconc (server-client-get client 'buffers) client-record))) + (process-put proc 'buffers + (nconc (process-get proc 'buffers) client-record))) client-record)) (defun server-buffer-done (buffer &optional for-killing) @@ -1010,23 +1065,23 @@ a temp file). FOR-KILLING if non-nil indicates that we are called from `kill-buffer'." (let ((next-buffer nil) (killed nil)) - (dolist (client server-clients) - (let ((buffers (server-client-get client 'buffers))) + (dolist (proc server-clients) + (let ((buffers (process-get proc 'buffers))) (or next-buffer (setq next-buffer (nth 1 (memq buffer buffers)))) (when buffers ; Ignore bufferless clients. (setq buffers (delq buffer buffers)) - ;; Delete all dead buffers from CLIENT. + ;; Delete all dead buffers from PROC. (dolist (b buffers) (and (bufferp b) (not (buffer-live-p b)) (setq buffers (delq b buffers)))) - (server-client-set client 'buffers buffers) + (process-put proc 'buffers buffers) ;; If client now has no pending buffers, ;; tell it that it is done, and forget it entirely. (unless buffers - (server-log "Close" client) - (server-delete-client client))))) + (server-log "Close" proc) + (server-delete-client proc))))) (when (and (bufferp buffer) (buffer-name buffer)) ;; We may or may not kill this buffer; ;; if we do, do not call server-buffer-done recursively @@ -1095,19 +1150,19 @@ specifically for the clients and did not exist before their request for it." (or (not server-buffer-clients) (let ((res t)) (dolist (proc server-buffer-clients res) - (let ((client (server-client proc))) - (when (and client (eq (process-status proc) 'open)) - (setq res nil))))) + (when (and (memq proc server-clients) + (eq (process-status proc) 'open)) + (setq res nil)))) (yes-or-no-p (format "Buffer `%s' still has clients; kill it? " (buffer-name (current-buffer)))))) (defun server-kill-emacs-query-function () - "Ask before exiting Emacs it has live clients." + "Ask before exiting Emacs if it has live clients." (or (not server-clients) (let (live-client) - (dolist (client server-clients live-client) - (when (memq t (mapcar 'buffer-live-p (server-client-get - client 'buffers))) + (dolist (proc server-clients live-client) + (when (memq t (mapcar 'buffer-live-p (process-get + proc 'buffers))) (setq live-client t)))) (yes-or-no-p "This Emacs session has clients; exit anyway? "))) @@ -1160,10 +1215,10 @@ done that." (progn (let ((rest server-clients)) (while (and rest (not next-buffer)) - (let ((client (car rest))) + (let ((proc (car rest))) ;; Only look at frameless clients. - (when (not (server-client-get client 'frame)) - (setq next-buffer (car (server-client-get client 'buffers)))) + (when (not (process-get proc 'frame)) + (setq next-buffer (car (process-get proc 'buffers)))) (setq rest (cdr rest))))) (and next-buffer (server-switch-buffer next-buffer killed-one)) (unless (or next-buffer killed-one (window-dedicated-p (selected-window))) @@ -1183,8 +1238,7 @@ done that." (select-window win) (set-buffer next-buffer)) ;; Otherwise, let's find an appropriate window. - (cond ((and (windowp server-window) - (window-live-p server-window)) + (cond ((window-live-p server-window) (select-window server-window)) ((framep server-window) (unless (frame-live-p server-window) @@ -1217,7 +1271,7 @@ With prefix arg, silently save all file-visiting buffers, then kill. If emacsclient was started with a list of filenames to edit, then only these files will be asked to be saved." - (let ((buffers (server-client-get proc 'buffers))) + (let ((buffers (process-get proc 'buffers))) ;; If client is bufferless, emulate a normal Emacs session ;; exit and offer to save all buffers. Otherwise, offer to ;; save only the buffers belonging to the client.