X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/38dbc4d81a2c4a707b04f2cae8bf9272763f34fb..2d0e8e614a6744a6a33c6b519f20359802e75c2b:/lisp/server.el diff --git a/lisp/server.el b/lisp/server.el index f0e88d0361..1e2f458ac9 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -1,8 +1,6 @@ -;;; server.el --- Lisp code for GNU Emacs running as server process +;;; server.el --- Lisp code for GNU Emacs running as server process -*- lexical-binding: t -*- -;; Copyright (C) 1986, 1987, 1992, 1994, 1995, 1996, 1997, 1998, 1999, 2000, -;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 1986-1987, 1992, 1994-2012 Free Software Foundation, Inc. ;; Author: William Sommerfeld ;; Maintainer: FSF @@ -110,10 +108,26 @@ If set, the server accepts remote connections; otherwise it is local." (string :tag "Name or IP address") (const :tag "Local" nil)) :version "22.1") +;;;###autoload (put 'server-host 'risky-local-variable t) +(defcustom server-port nil + "The port number that the server process should listen on. +This variable only takes effect when the Emacs server is using +TCP instead of local sockets. A nil value means to use a random +port number." + :group 'server + :type '(choice + (string :tag "Port number") + (const :tag "Random" nil)) + :version "24.1") +;;;###autoload +(put 'server-port 'risky-local-variable t) + (defcustom server-auth-dir (locate-user-emacs-file "server/") "Directory for server authentication files. +We only use this if `server-use-tcp' is non-nil. +Otherwise we use `server-socket-dir'. NOTE: On FAT32 filesystems, directories are not secure; files can be read and modified by any user or process. @@ -122,8 +136,35 @@ directory residing in a NTFS partition instead." :group 'server :type 'directory :version "22.1") +;;;###autoload (put 'server-auth-dir 'risky-local-variable t) +(defcustom server-auth-key nil + "Server authentication key. + +Normally, the authentication key is randomly generated when the +server starts, which guarantees some level of security. It is +recommended to leave it that way. Using a long-lived shared key +will decrease security (especially since the key is transmitted as +plain text). + +In some situations however, it can be difficult to share randomly +generated passwords with remote hosts (eg. no shared directory), +so you can set the key with this variable and then copy the +server file to the remote host (with possible changes to IP +address and/or port if that applies). + +The key must consist of 64 ASCII printable characters except for +space (this means characters from ! to ~; or from code 33 to 126). + +You can use \\[server-generate-key] to get a random authentication +key." + :group 'server + :type '(choice + (const :tag "Random" nil) + (string :tag "Password")) + :version "24.2") + (defcustom server-raise-frame t "If non-nil, raise frame when switching to a buffer." :group 'server @@ -225,9 +266,10 @@ If local sockets are not supported, this is nil.") (defun server-clients-with (property value) "Return a list of clients with PROPERTY set to VALUE." (let (result) - (dolist (proc server-clients result) + (dolist (proc server-clients) (when (equal value (process-get proc property)) - (push proc result))))) + (push proc result))) + result)) (defun server-add-client (proc) "Create a client for process PROC, if it doesn't already have one. @@ -293,11 +335,13 @@ Updates `server-clients'." (setq server-clients (delq proc server-clients)) - ;; Delete the client's tty. - (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 tty, except on Windows (both GUI and console), + ;; where there's only one terminal and does not make sense to delete it. + (unless (eq system-type 'windows-nt) + (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 proc) 'open) @@ -325,9 +369,9 @@ If CLIENT is non-nil, add a description of it to the logged message." (goto-char (point-max)) (insert (funcall server-log-time-function) (cond - ((null client) " ") - ((listp client) (format " %s: " (car client))) - (t (format " %s: " client))) + ((null client) " ") + ((listp client) (format " %s: " (car client))) + (t (format " %s: " client))) string) (or (bolp) (newline))))) @@ -345,22 +389,31 @@ If CLIENT is non-nil, add a description of it to the logged message." (and (process-contact proc :server) (eq (process-status proc) 'closed) (ignore-errors - (delete-file (process-get proc :server-file)))) + (delete-file (process-get proc :server-file)))) (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc) (server-delete-client proc)) +(defun server--on-display-p (frame display) + (and (equal (frame-parameter frame 'display) display) + ;; Note: TTY frames still get a `display' parameter set to the value of + ;; $DISPLAY. This is useful when running from that tty frame + ;; sub-processes that want to connect to the X server, but that means we + ;; have to be careful here not to be tricked into thinking those frames + ;; are on `display'. + (not (eq (framep frame) t)))) + (defun server-select-display (display) ;; If the current frame is on `display' we're all set. ;; Similarly if we are unable to open 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)) + (server--on-display-p (selected-frame) display)) ;; Otherwise, look for an existing frame there and select it. (dolist (frame (frame-list)) - (when (equal (frame-parameter frame 'display) display) + (when (server--on-display-p frame 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) + (unless (server--on-display-p (selected-frame) display) (let* ((buffer (generate-new-buffer " *server-dummy*")) (frame (make-frame-on-display display @@ -381,16 +434,19 @@ If CLIENT is non-nil, add a description of it to the logged message." ;; 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))) + + ;; Rewritten to avoid inadvertently killing the current buffer after + ;; `delete-frame' removed FRAME (Bug#10729). + (let ((buffer (frame-parameter frame 'server-dummy-buffer))) + (if (and (one-window-p 'nomini frame) + (eq (window-buffer (frame-first-window frame)) 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) + (set-frame-parameter frame 'server-dummy-buffer nil)) + (when (buffer-live-p buffer) + (kill-buffer buffer))))) (defun server-handle-delete-frame (frame) "Delete the client connection when the emacsclient frame is deleted. @@ -400,18 +456,19 @@ If CLIENT is non-nil, add a description of it to the logged message." proc ;; See if this is the last frame for this client. (>= 1 (let ((frame-num 0)) - (dolist (f (frame-list)) - (when (eq proc (frame-parameter f 'client)) - (setq frame-num (1+ frame-num)))) - frame-num))) + (dolist (f (frame-list)) + (when (eq proc (frame-parameter f 'client)) + (setq frame-num (1+ frame-num)))) + frame-num))) (server-log (format "server-handle-delete-frame, frame %s" frame) proc) (server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later. (defun server-handle-suspend-tty (terminal) - "Notify the emacsclient process to suspend itself when its tty device is suspended." + "Notify the client process that its tty device is suspended." (dolist (proc (server-clients-with 'terminal terminal)) - (server-log (format "server-handle-suspend-tty, terminal %s" terminal) proc) - (condition-case err + (server-log (format "server-handle-suspend-tty, terminal %s" terminal) + proc) + (condition-case nil (server-send-string proc "-suspend \n") (file-error ;The pipe/socket was closed. (ignore-errors (server-delete-client proc)))))) @@ -463,40 +520,70 @@ Creates the directory if necessary and makes sure: ;; Check that it's safe for use. (let* ((uid (nth 2 attrs)) (w32 (eq system-type 'windows-nt)) - (safe (catch :safe - (unless (eq t (car attrs)) ; is a dir? - (throw :safe nil)) - (when (and w32 (zerop uid)) ; on FAT32? - (display-warning - 'server - (format "Using `%s' to store Emacs-server authentication files. + (safe (cond + ((not (eq t (car attrs))) nil) ; is a dir? + ((and w32 (zerop uid)) ; on FAT32? + (display-warning + 'server + (format "Using `%s' to store Emacs-server authentication files. Directories on FAT32 filesystems are NOT secure against tampering. See variable `server-auth-dir' for details." - (file-name-as-directory dir)) - :warning) - (throw :safe t)) - (unless (eql uid (user-uid)) ; is the dir ours? - (throw :safe nil)) - (when w32 ; on NTFS? - (throw :safe t)) - (unless (zerop (logand ?\077 (file-modes dir))) - (throw :safe nil)) - t))) + (file-name-as-directory dir)) + :warning) + t) + ((and (/= uid (user-uid)) ; is the dir ours? + (or (not w32) + ;; Files created on Windows by Administrator + ;; (RID=500) have the Administrators (RID=544) + ;; group recorded as the owner. + (/= uid 544) (/= (user-uid) 500))) + nil) + (w32 t) ; on NTFS? + (t ; else, check permissions + (zerop (logand ?\077 (file-modes dir))))))) (unless safe (error "The directory `%s' is unsafe" dir))))) +(defun server-generate-key () + "Generate and return a random authentication key. +The key is a 64-byte string of random chars in the range `!'..`~'. +If called interactively, also inserts it into current buffer." + (interactive) + (let ((auth-key + (loop repeat 64 + collect (+ 33 (random 94)) into auth + finally return (concat auth)))) + (if (called-interactively-p 'interactive) + (insert auth-key)) + auth-key)) + +(defun server-get-auth-key () + "Return server's authentication key. + +If `server-auth-key' is nil, just call `server-generate-key'. +Otherwise, if `server-auth-key' is a valid key, return it. +If the key is not valid, signal an error." + (if server-auth-key + (if (string-match-p "^[!-~]\\{64\\}$" server-auth-key) + server-auth-key + (error "The key '%s' is invalid" server-auth-key)) + (server-generate-key))) + ;;;###autoload -(defun server-start (&optional leave-dead) +(defun server-start (&optional leave-dead inhibit-prompt) "Allow this Emacs process to be a server for client processes. -This starts a server communications subprocess through which -client \"editors\" can send your editing commands to this Emacs -job. To use the server, set up the program `emacsclient' in the -Emacs distribution as your standard \"editor\". +This starts a server communications subprocess through which client +\"editors\" can send your editing commands to this Emacs job. +To use the server, set up the program `emacsclient' in the Emacs +distribution as your standard \"editor\". Optional argument LEAVE-DEAD (interactively, a prefix arg) means just kill any existing server communications subprocess. -If a server is already running, the server is not started. +If a server is already running, restart it. If clients are +running, ask the user for confirmation first, unless optional +argument INHIBIT-PROMPT is non-nil. + To force-start a server, do \\[server-force-delete] and then \\[server-start]." (interactive "P") @@ -504,12 +591,14 @@ To force-start a server, do \\[server-force-delete] and then ;; Ask the user before deleting existing clients---except ;; when we can't get user input, which may happen when ;; doing emacsclient --eval "(kill-emacs)" in daemon mode. - (if (and (daemonp) - (null (cdr (frame-list))) - (eq (selected-frame) terminal-frame)) - leave-dead - (yes-or-no-p - "The current server still has clients; delete them? "))) + (cond + ((and (daemonp) + (null (cdr (frame-list))) + (eq (selected-frame) terminal-frame)) + leave-dead) + (inhibit-prompt t) + (t (yes-or-no-p + "The current server still has clients; delete them? ")))) (let* ((server-dir (if server-use-tcp server-auth-dir server-socket-dir)) (server-file (expand-file-name server-name server-dir))) (when server-process @@ -519,8 +608,8 @@ To force-start a server, do \\[server-force-delete] and then (if (not (eq t (server-running-p server-name))) ;; Remove any leftover socket or authentication file (ignore-errors - (let (delete-by-moving-to-trash) - (delete-file server-file))) + (let (delete-by-moving-to-trash) + (delete-file server-file))) (setq server-mode nil) ;; already set by the minor mode code (display-warning 'server @@ -548,7 +637,7 @@ server or call `M-x server-force-delete' to forcibly disconnect it.") (add-hook 'delete-frame-functions 'server-handle-delete-frame) (add-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function) (add-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function) - (add-hook 'kill-emacs-hook (lambda () (server-mode -1))) ;Cleanup upon exit. + (add-hook 'kill-emacs-hook 'server-force-stop) ;Cleanup upon exit. (setq server-process (apply #'make-network-process :name server-name @@ -564,8 +653,8 @@ server or call `M-x server-force-delete' to forcibly disconnect it.") ;; The other args depend on the kind of socket used. (if server-use-tcp (list :family 'ipv4 ;; We're not ready for IPv6 yet - :service t - :host (or server-host "127.0.0.1") ;; See bug#6781 + :service (or server-port t) + :host (or server-host 'local) :plist '(:authenticated nil)) (list :family 'local :service server-file @@ -573,22 +662,21 @@ server or call `M-x server-force-delete' to forcibly disconnect it.") (unless server-process (error "Could not start server process")) (process-put server-process :server-file server-file) (when server-use-tcp - (let ((auth-key - (loop - ;; The auth key is a 64-byte string of random chars in the - ;; range `!'..`~'. - repeat 64 - collect (+ 33 (random 94)) into auth - finally return (concat auth)))) + (let ((auth-key (server-get-auth-key))) (process-put server-process :auth-key auth-key) (with-temp-file server-file (set-buffer-multibyte nil) (setq buffer-file-coding-system 'no-conversion) (insert (format-network-address (process-contact server-process :local)) - " " (int-to-string (emacs-pid)) + " " (number-to-string (emacs-pid)) ; Kept for compatibility "\n" auth-key))))))))) +(defun server-force-stop () + "Kill all connections to the current server. +This function is meant to be called from `kill-emacs-hook'." + (server-start t t)) + ;;;###autoload (defun server-force-delete (&optional name) "Unconditionally delete connection file for server NAME. @@ -638,9 +726,13 @@ Return values: ;;;###autoload (define-minor-mode server-mode "Toggle Server mode. -With ARG, turn Server mode on if ARG is positive, off otherwise. +With a prefix argument ARG, enable Server mode if ARG is +positive, and disable it otherwise. If called from Lisp, enable +Server mode if ARG is omitted or nil. + Server mode runs a process that accepts commands from the -`emacsclient' program. See `server-start' and Info node `Emacs server'." +`emacsclient' program. See Info node `Emacs server' and +`server-start' for details." :global t :group 'server :version "22.1" @@ -650,16 +742,43 @@ Server mode runs a process that accepts commands from the (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) + ;; While we're running asynchronously (from a process filter), it is likely + ;; that the emacsclient command was run in response to a user + ;; action, so the user probably knows that Emacs is processing this + ;; emacsclient request, so if we get a C-g it's likely that the user + ;; intended it to interrupt us rather than interrupt whatever Emacs + ;; was doing before it started handling the process filter. + ;; Hence `with-local-quit' (bug#6585). + (let ((v (with-local-quit (eval (car (read-from-string expr)))))) + (when 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))))))))) + (server-reply-print (server-quote-arg text) proc))))))) + +(defconst server-msg-size 1024 + "Maximum size of a message sent to a client.") + +(defun server-reply-print (qtext proc) + "Send a `-print QTEXT' command to client PROC. +QTEXT must be already quoted. +This handles splitting the command if it would be bigger than +`server-msg-size'." + (let ((prefix "-print ") + part) + (while (> (+ (length qtext) (length prefix) 1) server-msg-size) + ;; We have to split the string + (setq part (substring qtext 0 (- server-msg-size (length prefix) 1))) + ;; Don't split in the middle of a quote sequence + (if (string-match "\\(^\\|[^&]\\)\\(&&\\)+$" part) + ;; There is an uneven number of & at the end + (setq part (substring part 0 -1))) + (setq qtext (substring qtext (length part))) + (server-send-string proc (concat prefix part "\n")) + (setq prefix "-print-nonl ")) + (server-send-string proc (concat prefix qtext "\n")))) (defun server-create-tty-frame (tty type proc) (unless tty @@ -669,31 +788,31 @@ Server mode runs a process that accepts commands from the (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 `((window-system . nil) - (tty . ,tty) - (tty-type . ,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))))))) + '("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 `((window-system . nil) + (tty . ,tty) + (tty-type . ,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. @@ -702,16 +821,10 @@ Server mode runs a process that accepts commands from the (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 parent-id) +(defun server-create-window-system-frame (display nowait proc parent-id + &optional parameters) (add-to-list 'frame-inherited-parameters 'client) (if (not (fboundp 'make-frame-on-display)) (progn @@ -726,7 +839,8 @@ Server mode runs a process that accepts commands from the ;; killing emacs on that frame. (let* ((params `((client . ,(if nowait 'nowait proc)) ;; This is a leftover, see above. - (environment . ,(process-get proc 'env)))) + (environment . ,(process-get proc 'env)) + ,@parameters)) (display (or display (frame-parameter nil 'display) (getenv "DISPLAY") @@ -739,9 +853,6 @@ Server mode runs a process that accepts commands from the (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) @@ -760,8 +871,7 @@ Server mode runs a process that accepts commands from the ;; 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)))) + (run-with-timer 0 nil (lambda () (server-execute-continuation proc))) (top-level))) ;; We use various special properties on process objects: @@ -808,6 +918,9 @@ The following commands are accepted by the server: `-current-frame' Forbid the creation of new frames. +`-frame-parameters ALIST' + Set the parameters of the created frame. + `-nowait' Request that the next frame created should not be associated with this client. @@ -861,8 +974,13 @@ The following commands are accepted by the client: Print STRING on stdout. Used to send values returned by -eval. +`-print-nonl STRING' + Print STRING on stdout. Used to continue a + preceding -print command that would be too big to send + in a single message. + `-error DESCRIPTION' - Signal an error (but continue processing). + Signal an error and delete process PROC. `-suspend' Suspend this terminal, i.e., stop the client process. @@ -879,6 +997,9 @@ The following commands are accepted by the client: (server-log "Authentication failed" proc) (server-send-string proc (concat "-error " (server-quote-arg "Authentication failed"))) + ;; Before calling `delete-process', give emacsclient time to + ;; receive the error string and shut down on its own. + (sit-for 1) (delete-process proc) ;; We return immediately (return-from server-process-filter))) @@ -889,6 +1010,9 @@ The following commands are accepted by the client: (condition-case err (progn (server-add-client proc) + ;; Send our pid + (server-send-string proc (concat "-emacs-pid " + (number-to-string (emacs-pid)) "\n")) (if (not (string-match "\n" string)) ;; Save for later any partial line that remains. (when (> (length string) 0) @@ -910,130 +1034,147 @@ The following commands are accepted by the client: commands dir use-current-frame + frame-parameters ;parameters for newly created frame tty-name ; nil, `window-system', or the tty name. tty-type ; string. files filepos - command-line-args-left - arg) + args-left) ;; Remove this line from STRING. (setq string (substring string (match-end 0))) - (setq command-line-args-left + (setq args-left (mapcar 'server-unquote-arg (split-string request " " t))) - (while (setq arg (pop command-line-args-left)) - (cond - ;; -version CLIENT-VERSION: obsolete at birth. - ((and (equal "-version" arg) command-line-args-left) - (pop command-line-args-left)) - - ;; -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 use-current-frame t)) - - ;; -display DISPLAY: - ;; Open X frames on the given display instead of the default. - ((and (equal "-display" arg) command-line-args-left) - (setq display (pop command-line-args-left)) - (if (zerop (length display)) (setq display nil))) - - ;; -parent-id ID: - ;; Open X frame within window ID, via XEmbed. - ((and (equal "-parent-id" arg) command-line-args-left) - (setq parent-id (pop command-line-args-left)) - (if (zerop (length parent-id)) (setq parent-id nil))) - - ;; -window-system: Open a new X frame. - ((equal "-window-system" arg) - (setq dontkill t) - (setq tty-name 'window-system)) - - ;; -resume: Resume a suspended tty frame. - ((equal "-resume" arg) - (lexical-let ((terminal (process-get proc 'terminal))) - (setq dontkill t) - (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) - (lexical-let ((terminal (process-get proc 'terminal))) - (setq dontkill t) - (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) command-line-args-left - (setq dontkill t) - (pop command-line-args-left))) - - ;; -tty DEVICE-NAME TYPE: Open a new tty frame at the client. - ((and (equal "-tty" arg) - (cdr command-line-args-left)) - (setq tty-name (pop command-line-args-left) - tty-type (pop command-line-args-left) - dontkill (or dontkill - (not use-current-frame)))) - - ;; -position LINE[:COLUMN]: Set point to the given - ;; position in the next file. - ((and (equal "-position" arg) - command-line-args-left - (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?" - (car command-line-args-left))) - (setq arg (pop command-line-args-left)) - (setq filepos - (cons (string-to-number (match-string 1 arg)) - (string-to-number (or (match-string 2 arg) ""))))) - - ;; -file FILENAME: Load the given file. - ((and (equal "-file" arg) - command-line-args-left) - (let ((file (pop command-line-args-left))) - (if coding-system - (setq file (decode-coding-string file coding-system))) - (setq file (expand-file-name file dir)) - (push (cons file filepos) files) - (server-log (format "New file: %s %s" - file (or filepos "")) proc)) - (setq filepos nil)) - - ;; -eval EXPR: Evaluate a Lisp expression. - ((and (equal "-eval" arg) - command-line-args-left) - (if use-current-frame - (setq use-current-frame 'always)) - (lexical-let ((expr (pop command-line-args-left))) - (if coding-system - (setq expr (decode-coding-string expr coding-system))) - (push (lambda () (server-eval-and-print expr proc)) - commands) - (setq filepos nil))) - - ;; -env NAME=VALUE: An environment variable. - ((and (equal "-env" arg) command-line-args-left) - (let ((var (pop command-line-args-left))) - ;; XXX Variables should be encoded as in getenv/setenv. - (process-put proc 'env - (cons var (process-get proc 'env))))) - - ;; -dir DIRNAME: The cwd of the emacsclient process. - ((and (equal "-dir" arg) command-line-args-left) - (setq dir (pop command-line-args-left)) - (if coding-system - (setq dir (decode-coding-string dir coding-system))) - (setq dir (command-line-normalize-file-name dir))) - - ;; Unknown command. - (t (error "Unknown command: %s" arg)))) + (while args-left + (pcase (pop args-left) + ;; -version CLIENT-VERSION: obsolete at birth. + (`"-version" (pop args-left)) + + ;; -nowait: Emacsclient won't wait for a result. + (`"-nowait" (setq nowait t)) + + ;; -current-frame: Don't create frames. + (`"-current-frame" (setq use-current-frame t)) + + ;; -frame-parameters: Set frame parameters + (`"-frame-parameters" + (let ((alist (pop args-left))) + (if coding-system + (setq alist (decode-coding-string alist coding-system))) + (setq frame-parameters (car (read-from-string alist))))) + + ;; -display DISPLAY: + ;; Open X frames on the given display instead of the default. + (`"-display" + (setq display (pop args-left)) + (if (zerop (length display)) (setq display nil))) + + ;; -parent-id ID: + ;; Open X frame within window ID, via XEmbed. + (`"-parent-id" + (setq parent-id (pop args-left)) + (if (zerop (length parent-id)) (setq parent-id nil))) + + ;; -window-system: Open a new X frame. + (`"-window-system" + (if (fboundp 'x-create-frame) + (setq dontkill t + tty-name 'window-system))) + + ;; -resume: Resume a suspended tty frame. + (`"-resume" + (let ((terminal (process-get proc 'terminal))) + (setq dontkill t) + (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.) + (`"-suspend" + (let ((terminal (process-get proc 'terminal))) + (setq dontkill t) + (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.) + (`"-ignore" + (setq dontkill t) + (pop args-left)) + + ;; -tty DEVICE-NAME TYPE: Open a new tty frame. + ;; (But if we see -window-system later, use that.) + (`"-tty" + (setq tty-name (pop args-left) + tty-type (pop args-left) + dontkill (or dontkill + (not use-current-frame))) + ;; On Windows, emacsclient always asks for a tty frame. + ;; If running a GUI server, force the frame type to GUI. + (when (eq window-system 'w32) + (push "-window-system" args-left))) + + ;; -position LINE[:COLUMN]: Set point to the given + ;; position in the next file. + (`"-position" + (if (not (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?" + (car args-left))) + (error "Invalid -position command in client args")) + (let ((arg (pop args-left))) + (setq filepos + (cons (string-to-number (match-string 1 arg)) + (string-to-number (or (match-string 2 arg) + "")))))) + + ;; -file FILENAME: Load the given file. + (`"-file" + (let ((file (pop args-left))) + (if coding-system + (setq file (decode-coding-string file coding-system))) + (setq file (expand-file-name file dir)) + (push (cons file filepos) files) + (server-log (format "New file: %s %s" + file (or filepos "")) proc)) + (setq filepos nil)) + + ;; -eval EXPR: Evaluate a Lisp expression. + (`"-eval" + (if use-current-frame + (setq use-current-frame 'always)) + (let ((expr (pop args-left))) + (if coding-system + (setq expr (decode-coding-string expr coding-system))) + (push (lambda () (server-eval-and-print expr proc)) + commands) + (setq filepos nil))) + + ;; -env NAME=VALUE: An environment variable. + (`"-env" + (let ((var (pop args-left))) + ;; XXX Variables should be encoded as in getenv/setenv. + (process-put proc 'env + (cons var (process-get proc 'env))))) + + ;; -dir DIRNAME: The cwd of the emacsclient process. + (`"-dir" + (setq dir (pop args-left)) + (if coding-system + (setq dir (decode-coding-string dir coding-system))) + (setq dir (command-line-normalize-file-name dir))) + + ;; Unknown command. + (arg (error "Unknown command: %s" arg)))) + + ;; If both -no-wait and -tty are given with file or sexp + ;; arguments, use an existing frame. + (and nowait + (not (eq tty-name 'window-system)) + (or files commands) + (setq use-current-frame t)) (setq frame (cond @@ -1049,30 +1190,23 @@ The following commands are accepted by the client: (if display (server-select-display display))) ((eq tty-name 'window-system) (server-create-window-system-frame display nowait proc - parent-id)) + parent-id + frame-parameters)) ;; When resuming on a tty, tty-name is nil. (tty-name (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) - (dir dir) - (tty-name tty-name)) - (lambda () - (with-current-buffer (get-buffer-create server-buffer) - ;; Use the same cwd as the emacsclient, if possible, so - ;; relative file names work correctly, even in `eval'. - (let ((default-directory - (if (and dir (file-directory-p dir)) - dir default-directory))) - (server-execute proc files nowait commands - dontkill frame tty-name)))))) + (lambda () + (with-current-buffer (get-buffer-create server-buffer) + ;; Use the same cwd as the emacsclient, if possible, so + ;; relative file names work correctly, even in `eval'. + (let ((default-directory + (if (and dir (file-directory-p dir)) + dir default-directory))) + (server-execute proc files nowait commands + dontkill frame tty-name))))) (when (or frame files) (server-goto-toplevel proc)) @@ -1091,12 +1225,17 @@ The following commands are accepted by the client: ;; including code that needs to wait. (with-local-quit (condition-case err - (let* ((buffers - (when files - (server-visit-files files proc nowait)))) - + (let ((buffers (server-visit-files files proc nowait))) (mapc 'funcall (nreverse commands)) + ;; If we were told only to open a new client, obey + ;; `initial-buffer-choice' if it specifies a file. + (unless (or files commands) + (if (stringp initial-buffer-choice) + (find-file initial-buffer-choice) + (switch-to-buffer (get-buffer-create "*scratch*") + 'norecord))) + ;; Delete the client if necessary. (cond (nowait @@ -1121,7 +1260,10 @@ The following commands are accepted by the client: "When done with a buffer, type \\[server-edit]"))))) (when (and frame (null tty-name)) (server-unselect-display frame))) - (error (server-return-error proc err))))) + ((quit error) + (when (eq (car err) 'quit) + (message "Quit emacsclient request")) + (server-return-error proc err))))) (defun server-return-error (proc err) (ignore-errors @@ -1129,6 +1271,9 @@ The following commands are accepted by the client: proc (concat "-error " (server-quote-arg (error-message-string err)))) (server-log (error-message-string err) proc) + ;; Before calling `delete-process', give emacsclient time to + ;; receive the error string and shut down on its own. + (sit-for 5) (delete-process proc))) (defun server-goto-line-column (line-col) @@ -1165,12 +1310,12 @@ so don't mark these buffers specially, just visit them normally." (add-to-history 'file-name-history filen) (if (null obuf) (progn - (run-hooks 'pre-command-hook) + (run-hooks 'pre-command-hook) (set-buffer (find-file-noselect filen))) (set-buffer obuf) ;; separately for each file, in sync with post-command hooks, ;; with the new buffer current: - (run-hooks 'pre-command-hook) + (run-hooks 'pre-command-hook) (cond ((file-exists-p filen) (when (not (verify-visited-file-modtime obuf)) (revert-buffer t nil))) @@ -1184,7 +1329,7 @@ so don't mark these buffers specially, just visit them normally." (server-goto-line-column (cdr file)) (run-hooks 'server-visit-hook) ;; hooks may be specific to current buffer: - (run-hooks 'post-command-hook)) + (run-hooks 'post-command-hook)) (unless nowait ;; When the buffer is killed, inform the clients. (add-hook 'kill-buffer-hook 'server-kill-buffer nil t) @@ -1194,7 +1339,10 @@ so don't mark these buffers specially, just visit them normally." (process-put proc 'buffers (nconc (process-get proc 'buffers) client-record))) client-record)) - + +(defvar server-kill-buffer-running nil + "Non-nil while `server-kill-buffer' or `server-buffer-done' is running.") + (defun server-buffer-done (buffer &optional for-killing) "Mark BUFFER as \"done\" for its client(s). This buries the buffer, then returns a list of the form (NEXT-BUFFER KILLED). @@ -1299,10 +1447,11 @@ specifically for the clients and did not exist before their request for it." "Ask before killing a server buffer." (or (not server-buffer-clients) (let ((res t)) - (dolist (proc server-buffer-clients res) + (dolist (proc server-buffer-clients) (when (and (memq proc server-clients) (eq (process-status proc) 'open)) - (setq res nil)))) + (setq res nil))) + res) (yes-or-no-p (format "Buffer `%s' still has clients; kill it? " (buffer-name (current-buffer)))))) @@ -1310,15 +1459,13 @@ specifically for the clients and did not exist before their request for it." "Ask before exiting Emacs if it has live clients." (or (not server-clients) (let (live-client) - (dolist (proc server-clients live-client) + (dolist (proc server-clients) (when (memq t (mapcar 'buffer-live-p (process-get proc 'buffers))) - (setq live-client t)))) + (setq live-client t))) + live-client) (yes-or-no-p "This Emacs session has clients; exit anyway? "))) -(defvar server-kill-buffer-running nil - "Non-nil while `server-kill-buffer' or `server-buffer-done' is running.") - (defun server-kill-buffer () "Remove the current buffer from its clients' buffer list. Designed to be added to `kill-buffer-hook'." @@ -1346,12 +1493,12 @@ If invoked with a prefix argument, or if there is no server process running, starts server process and that is all. Invoked by \\[server-edit]." (interactive "P") (cond - ((or arg - (not server-process) - (memq (process-status server-process) '(signal exit))) - (server-mode 1)) - (server-clients (apply 'server-switch-buffer (server-done))) - (t (message "No server editing buffers exist")))) + ((or arg + (not server-process) + (memq (process-status server-process) '(signal exit))) + (server-mode 1)) + (server-clients (apply 'server-switch-buffer (server-done))) + (t (message "No server editing buffers exist")))) (defun server-switch-buffer (&optional next-buffer killed-one filepos) "Switch to another buffer, preferably one that has a client. @@ -1464,8 +1611,61 @@ only these files will be asked to be saved." ;; continue standard unloading nil) +(defun server-eval-at (server form) + "Contact the Emacs server named SERVER and evaluate FORM there. +Returns the result of the evaluation, or signals an error if it +cannot contact the specified server. For example: + \(server-eval-at \"server\" '(emacs-pid)) +returns the process ID of the Emacs instance running \"server\"." + (let* ((server-dir (if server-use-tcp server-auth-dir server-socket-dir)) + (server-file (expand-file-name server server-dir)) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary) + address port secret process) + (unless (file-exists-p server-file) + (error "No such server: %s" server)) + (with-temp-buffer + (when server-use-tcp + (let ((coding-system-for-read 'no-conversion)) + (insert-file-contents server-file) + (unless (looking-at "\\([0-9.]+\\):\\([0-9]+\\)") + (error "Invalid auth file")) + (setq address (match-string 1) + port (string-to-number (match-string 2))) + (forward-line 1) + (setq secret (buffer-substring (point) (line-end-position))) + (erase-buffer))) + (unless (setq process (make-network-process + :name "eval-at" + :buffer (current-buffer) + :host address + :service (if server-use-tcp port server-file) + :family (if server-use-tcp 'ipv4 'local) + :noquery t)) + (error "Unable to contact the server")) + (if server-use-tcp + (process-send-string process (concat "-auth " secret "\n"))) + (process-send-string process + (concat "-eval " + (server-quote-arg (format "%S" form)) + "\n")) + (while (memq (process-status process) '(open run)) + (accept-process-output process 0 10)) + (goto-char (point-min)) + ;; If the result is nil, there's nothing in the buffer. If the + ;; result is non-nil, it's after "-print ". + (let ((answer "")) + (while (re-search-forward "\n-print\\(-nonl\\)? " nil t) + (setq answer + (concat answer + (buffer-substring (point) + (progn (skip-chars-forward "^\n") + (point)))))) + (if (not (equal answer "")) + (read (decode-coding-string (server-unquote-arg answer) + 'emacs-internal))))))) + (provide 'server) -;; arch-tag: 1f7ecb42-f00a-49f8-906d-61995d84c8d6 ;;; server.el ends here