diff options
Diffstat (limited to 'lisp/server.el')
| -rw-r--r-- | lisp/server.el | 264 |
1 files changed, 143 insertions, 121 deletions
diff --git a/lisp/server.el b/lisp/server.el index 42329e853ba..d491a260377 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -96,7 +96,6 @@ (unless load-in-progress (message "Local sockets unsupported, using TCP sockets"))) (set-default sym val)) - :group 'server :type 'boolean :version "22.1") @@ -108,7 +107,6 @@ DO NOT give this a non-nil value unless you know what you are doing! On unsecured networks, accepting remote connections is very dangerous, because server-client communication (including session authentication) is not encrypted." - :group 'server :type '(choice (string :tag "Name or IP address") (const :tag "Local" nil)) @@ -121,7 +119,6 @@ is not encrypted." 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)) @@ -138,7 +135,6 @@ NOTE: On FAT32 filesystems, directories are not secure; files can be read and modified by any user or process. It is strongly suggested to set `server-auth-dir' to a directory residing in a NTFS partition instead." - :group 'server :type 'directory :version "22.1") ;;;###autoload @@ -166,7 +162,6 @@ communications are unencrypted, still apply. 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 key." - :group 'server :type '(choice (const :tag "Random" nil) (string :tag "Password")) @@ -174,23 +169,25 @@ space (this means characters from ! to ~; or from code 33 to (defcustom server-raise-frame t "If non-nil, raise frame when switching to a buffer." - :group 'server :type 'boolean :version "22.1") (defcustom server-visit-hook nil "Hook run when visiting a file for the Emacs server." - :group 'server :type 'hook) (defcustom server-switch-hook nil "Hook run when switching to a buffer for the Emacs server." - :group 'server :type 'hook) +(defcustom server-after-make-frame-hook nil + "Hook run when the Emacs server creates a client frame. +The created frame is selected when the hook is called." + :type 'hook + :version "27.1") + (defcustom server-done-hook nil "Hook run when done editing a buffer for the Emacs server." - :group 'server :type 'hook) (defvar server-process nil @@ -216,7 +213,6 @@ If it is a frame, use the frame's selected window. It is not meaningful to set this to a specific frame or window with Custom. Only programs can do so." - :group 'server :version "22.1" :type '(choice (const :tag "Use selected window" :match (lambda (widget value) @@ -226,11 +222,10 @@ Only programs can do so." (function-item :tag "Use pop-to-buffer" pop-to-buffer) (function :tag "Other function"))) -(defcustom server-temp-file-regexp "^/tmp/Re\\|/draft$" +(defcustom server-temp-file-regexp "\\`/tmp/Re\\|/draft\\'" "Regexp matching names of temporary files. These are deleted and reused after each edit by the programs that invoke the Emacs server." - :group 'server :type 'regexp) (defcustom server-kill-new-buffers t @@ -241,7 +236,6 @@ it with the Emacs server. If nil, kill only buffers as specified by 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 :version "21.1") @@ -251,8 +245,16 @@ This means that the server should not kill the buffer when you say you are done with it in the server.") (make-variable-buffer-local 'server-existing-buffer) -;;;###autoload -(defcustom server-name "server" +(defvar server--external-socket-initialized nil + "When an external socket is passed into Emacs, we need to call +`server-start' in order to initialize the connection. This flag +prevents multiple initializations when an external socket has +been consumed.") + +(defcustom server-name + (if internal--daemon-sockname + (file-name-nondirectory internal--daemon-sockname) + "server") "The name of the Emacs server, if this Emacs process creates one. The command `server-start' makes use of this. It should not be changed while a server is running. @@ -263,15 +265,19 @@ If this is an absolute file name, it specifies where the socket file will be created. To have emacsclient connect to the same socket, use the \"-s\" switch for local non-TCP sockets, and the \"-f\" switch otherwise." - :group 'server :type 'string :version "23.1") ;; We do not use `temporary-file-directory' here, because emacsclient ;; does not read the init file. (defvar server-socket-dir - (and (featurep 'make-network-process '(:family local)) - (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid))) + (if internal--daemon-sockname + (file-name-directory internal--daemon-sockname) + (and (featurep 'make-network-process '(:family local)) + (let ((xdg_runtime_dir (getenv "XDG_RUNTIME_DIR"))) + (if xdg_runtime_dir + (format "%s/emacs" xdg_runtime_dir) + (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid)))))) "The directory in which to place the server socket. If local sockets are not supported, this is nil.") @@ -361,7 +367,7 @@ Updates `server-clients'." (server-log "Deleted" proc)))) -(defvar server-log-time-function 'current-time-string +(defvar server-log-time-function #'current-time-string "Function to generate timestamps for `server-buffer'.") (defconst server-buffer " *server*" @@ -530,13 +536,13 @@ Creates the directory if necessary and makes sure: (setq attrs (file-attributes dir 'integer))) ;; Check that it's safe for use. - (let* ((uid (nth 2 attrs)) + (let* ((uid (file-attribute-user-id attrs)) (w32 (eq system-type 'windows-nt)) (unsafe (cond - ((not (eq t (car attrs))) + ((not (eq t (file-attribute-type attrs))) (if (null attrs) "its attributes can't be checked" (format "it is a %s" - (if (stringp (car attrs)) + (if (stringp (file-attribute-type attrs)) "symlink" "file")))) ((and w32 (zerop uid)) ; on FAT32? (display-warning @@ -628,23 +634,29 @@ the `server-process' variable." (when server-process ;; kill it dead! (ignore-errors (delete-process server-process))) - ;; Delete the socket files made by previous server invocations. - (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))) - (setq server-mode nil) ;; already set by the minor mode code - (display-warning - 'server - (concat "Unable to start the Emacs server.\n" - (format "There is an existing Emacs server, named %S.\n" - server-name) - (substitute-command-keys - "To start the server in this Emacs process, stop the existing + ;; Check to see if an uninitialized external socket has been + ;; passed in, if that is the case, skip checking + ;; `server-running-p' as this will return the wrong result. + (if (and internal--daemon-sockname + (not server--external-socket-initialized)) + (setq server--external-socket-initialized t) + ;; Delete the socket files made by previous server invocations. + (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))) + (setq server-mode nil) ;; already set by the minor mode code + (display-warning + 'server + (concat "Unable to start the Emacs server.\n" + (format "There is an existing Emacs server, named %S.\n" + server-name) + (substitute-command-keys + "To start the server in this Emacs process, stop the existing server or call `\\[server-force-delete]' to forcibly disconnect it.")) - :warning) - (setq leave-dead t)) + :warning) + (setq leave-dead t))) ;; If this Emacs already had a server, clear out associated status. (while server-clients (server-delete-client (car server-clients))) @@ -658,16 +670,16 @@ server or call `\\[server-force-delete]' to forcibly disconnect it.")) (when server-process (server-log (message "Restarting server"))) (cl-letf (((default-file-modes) ?\700)) - (add-hook 'suspend-tty-functions 'server-handle-suspend-tty) - (add-hook 'delete-frame-functions 'server-handle-delete-frame) + (add-hook 'suspend-tty-functions #'server-handle-suspend-tty) + (add-hook 'delete-frame-functions #'server-handle-delete-frame) (add-hook 'kill-emacs-query-functions - 'server-kill-emacs-query-function) + #'server-kill-emacs-query-function) ;; We put server's kill-emacs-hook after the others, so that ;; frames are not deleted too early, because doing that ;; would severely degrade our abilities to communicate with ;; the user, while some hooks may wish to ask the user ;; questions (e.g., desktop-kill). - (add-hook 'kill-emacs-hook 'server-force-stop t) ;Cleanup upon exit. + (add-hook 'kill-emacs-hook #'server-force-stop t) ;Cleanup upon exit. (setq server-process (apply #'make-network-process :name server-name @@ -761,15 +773,11 @@ by the current Emacs process, use the `server-process' variable." ;;;###autoload (define-minor-mode server-mode "Toggle Server mode. -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 Info node `Emacs server' and `server-start' for details." :global t - :group 'server :version "22.1" ;; Fixme: Should this check for an existing server socket and do ;; nothing if there is one (for multiple Emacs sessions)? @@ -784,7 +792,7 @@ Server mode runs a process that accepts commands from the ;; 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)))))) + (let ((v (with-local-quit (eval (car (read-from-string expr)) t)))) (when proc (with-temp-buffer (let ((standard-output (current-buffer))) @@ -815,7 +823,7 @@ This handles splitting the command if it would be bigger than (setq prefix "-print-nonl ")) (server-send-string proc (concat prefix qtext "\n")))) -(defun server-create-tty-frame (tty type proc) +(defun server-create-tty-frame (tty type proc &optional parameters) (unless tty (error "Invalid terminal device")) (unless type @@ -848,7 +856,8 @@ This handles splitting the command if it would be bigger than ;; envvars, and then to change the ;; C functions `child_setup' and ;; `getenv_internal' accordingly. - (environment . ,(process-get proc 'env))))))) + (environment . ,(process-get proc 'env)) + ,@parameters))))) ;; ttys don't use the `display' parameter, but callproc.c does to set ;; the DISPLAY environment on subprocesses. @@ -1075,9 +1084,8 @@ The following commands are accepted by the client: ;; supported any more. (cl-assert (eq (match-end 0) (length string))) (let ((request (substring string 0 (match-beginning 0))) - (coding-system (and (default-value 'enable-multibyte-characters) - (or file-name-coding-system - default-file-name-coding-system))) + (coding-system (or file-name-coding-system + default-file-name-coding-system)) nowait ; t if emacsclient does not want to wait for us. frame ; Frame opened for the client (if any). display ; Open frame on this display. @@ -1091,24 +1099,25 @@ The following commands are accepted by the client: tty-type ; string. files filepos - args-left) + args-left + create-frame-func) ;; Remove this line from STRING. (setq string (substring string (match-end 0))) (setq args-left - (mapcar 'server-unquote-arg (split-string request " " t))) + (mapcar #'server-unquote-arg (split-string request " " t))) (while args-left (pcase (pop args-left) ;; -version CLIENT-VERSION: obsolete at birth. - (`"-version" (pop args-left)) + ("-version" (pop args-left)) ;; -nowait: Emacsclient won't wait for a result. - (`"-nowait" (setq nowait t)) + ("-nowait" (setq nowait t)) ;; -current-frame: Don't create frames. - (`"-current-frame" (setq use-current-frame t)) + ("-current-frame" (setq use-current-frame t)) ;; -frame-parameters: Set frame parameters - (`"-frame-parameters" + ("-frame-parameters" (let ((alist (pop args-left))) (if coding-system (setq alist (decode-coding-string alist coding-system))) @@ -1116,24 +1125,24 @@ The following commands are accepted by the client: ;; -display DISPLAY: ;; Open X frames on the given display instead of the default. - (`"-display" + ("-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" + ("-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" + ("-window-system" (if (fboundp 'x-create-frame) (setq dontkill t tty-name 'window-system))) ;; -resume: Resume a suspended tty frame. - (`"-resume" + ("-resume" (let ((terminal (process-get proc 'terminal))) (setq dontkill t) (push (lambda () @@ -1144,7 +1153,7 @@ The following commands are accepted by the client: ;; -suspend: Suspend the client's frame. (In case we ;; get out of sync, and a C-z sends a SIGTSTP to ;; emacsclient.) - (`"-suspend" + ("-suspend" (let ((terminal (process-get proc 'terminal))) (setq dontkill t) (push (lambda () @@ -1154,13 +1163,13 @@ The following commands are accepted by the client: ;; -ignore COMMENT: Noop; useful for debugging emacsclient. ;; (The given comment appears in the server log.) - (`"-ignore" + ("-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" + ("-tty" (setq tty-name (pop args-left) tty-type (pop args-left) dontkill (or dontkill @@ -1179,7 +1188,7 @@ The following commands are accepted by the client: ;; -position LINE[:COLUMN]: Set point to the given ;; position in the next file. - (`"-position" + ("-position" (if (not (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?" (car args-left))) (error "Invalid -position command in client args")) @@ -1190,7 +1199,7 @@ The following commands are accepted by the client: "")))))) ;; -file FILENAME: Load the given file. - (`"-file" + ("-file" (let ((file (pop args-left))) (if coding-system (setq file (decode-coding-string file coding-system))) @@ -1208,7 +1217,7 @@ The following commands are accepted by the client: (setq filepos nil)) ;; -eval EXPR: Evaluate a Lisp expression. - (`"-eval" + ("-eval" (if use-current-frame (setq use-current-frame 'always)) (let ((expr (pop args-left))) @@ -1219,14 +1228,14 @@ The following commands are accepted by the client: (setq filepos nil))) ;; -env NAME=VALUE: An environment variable. - (`"-env" + ("-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" + ("-dir" (setq dir (pop args-left)) (if coding-system (setq dir (decode-coding-string dir coding-system))) @@ -1243,28 +1252,29 @@ The following commands are accepted by the client: (or files commands) (setq use-current-frame t)) - (setq frame - (cond - ((and use-current-frame - (or (eq use-current-frame 'always) - ;; We can't use the Emacs daemon's - ;; terminal frame. - (not (and (daemonp) - (null (cdr (frame-list))) - (eq (selected-frame) - terminal-frame))))) - (setq tty-name nil tty-type nil) - (if display (server-select-display display))) - ((or (and (eq system-type 'windows-nt) - (daemonp) - (setq display "w32")) - (eq tty-name 'window-system)) - (server-create-window-system-frame display nowait proc - parent-id - frame-parameters)) - ;; When resuming on a tty, tty-name is nil. - (tty-name - (server-create-tty-frame tty-name tty-type proc)))) + (setq create-frame-func + (lambda () + (cond + ((and use-current-frame + (or (eq use-current-frame 'always) + ;; We can't use the Emacs daemon's + ;; terminal frame. + (not (and (daemonp) + (null (cdr (frame-list))) + (eq (selected-frame) + terminal-frame))))) + (setq tty-name nil tty-type nil) + (if display (server-select-display display))) + ((or (and (eq system-type 'windows-nt) + (daemonp) + (setq display "w32")) + (eq tty-name 'window-system)) + (server-create-window-system-frame display nowait proc + 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 @@ -1276,16 +1286,16 @@ The following commands are accepted by the client: (if (and dir (file-directory-p dir)) dir default-directory))) (server-execute proc files nowait commands - dontkill frame tty-name))))) + dontkill create-frame-func tty-name))))) (when (or frame files) (server-goto-toplevel proc)) (server-execute-continuation proc)))) ;; condition-case - (error (server-return-error proc err)))) + (t (server-return-error proc err)))) -(defun server-execute (proc files nowait commands dontkill frame tty-name) +(defun server-execute (proc files nowait commands dontkill create-frame-func tty-name) ;; This is run from timers and process-filters, i.e. "asynchronously". ;; But w.r.t the user, this is not really asynchronous since the timer ;; is run after 0s and the process-filter is run in response to the @@ -1295,21 +1305,29 @@ The following commands are accepted by the client: ;; including code that needs to wait. (with-local-quit (condition-case err - (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 - ;; or a function. - (unless (or files commands) - (let ((buf - (cond ((stringp initial-buffer-choice) - (find-file-noselect initial-buffer-choice)) - ((functionp initial-buffer-choice) - (funcall initial-buffer-choice))))) - (switch-to-buffer - (if (buffer-live-p buf) buf (get-buffer-create "*scratch*")) - 'norecord))) + (let* ((buffers (server-visit-files files proc nowait)) + ;; If we were told only to open a new client, obey + ;; `initial-buffer-choice' if it specifies a file + ;; or a function. + (initial-buffer (unless (or files commands) + (let ((buf + (cond ((stringp initial-buffer-choice) + (find-file-noselect initial-buffer-choice)) + ((functionp initial-buffer-choice) + (funcall initial-buffer-choice))))) + (if (buffer-live-p buf) buf (startup--get-buffer-create-scratch))))) + ;; Set current buffer so that newly created tty frames + ;; show the correct buffer initially. + (frame (with-current-buffer (or (car buffers) + initial-buffer + (current-buffer)) + (prog1 + (funcall create-frame-func) + ;; Switch to initial buffer in case the frame was reused. + (when initial-buffer + (switch-to-buffer initial-buffer 'norecord)))))) + + (mapc #'funcall (nreverse commands)) ;; Delete the client if necessary. (cond @@ -1325,9 +1343,11 @@ The following commands are accepted by the client: ((or isearch-mode (minibufferp)) nil) ((and frame (null buffers)) + (run-hooks 'server-after-make-frame-hook) (message "%s" (substitute-command-keys "When done with this frame, type \\[delete-frame]"))) ((not (null buffers)) + (run-hooks 'server-after-make-frame-hook) (server-switch-buffer (car buffers) nil (cdr (car files))) (run-hooks 'server-switch-hook) (unless nowait @@ -1407,7 +1427,7 @@ so don't mark these buffers specially, just visit them normally." (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) + (add-hook 'kill-buffer-hook #'server-kill-buffer nil t) (push proc server-buffer-clients)) (push (current-buffer) client-record))) (unless nowait @@ -1518,8 +1538,8 @@ specifically for the clients and did not exist before their request for it." "Ask before exiting Emacs if it has live clients." (or (not (let (live-client) (dolist (proc server-clients) - (when (memq t (mapcar 'buffer-live-p (process-get - proc 'buffers))) + (when (memq t (mapcar #'buffer-live-p + (process-get proc 'buffers))) (setq live-client t))) live-client)) (yes-or-no-p "This Emacs session has clients; exit anyway? "))) @@ -1555,7 +1575,7 @@ starts server process and that is all. Invoked by \\[server-edit]." (not server-process) (memq (process-status server-process) '(signal exit))) (server-mode 1)) - (server-clients (apply 'server-switch-buffer (server-done))) + (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) @@ -1588,7 +1608,7 @@ be a cons cell (LINENUMBER . COLUMNNUMBER)." (if (not (buffer-live-p next-buffer)) ;; If NEXT-BUFFER is a dead buffer, remove the server records for it ;; and try the next surviving server buffer. - (apply 'server-switch-buffer (server-buffer-done next-buffer)) + (apply #'server-switch-buffer (server-buffer-done next-buffer)) ;; OK, we know next-buffer is live, let's display and select it. (if (functionp server-window) (funcall server-window next-buffer) @@ -1653,13 +1673,15 @@ only these files will be asked to be saved." (save-buffers-kill-emacs arg))) ((processp proc) (let ((buffers (process-get proc 'buffers))) - ;; If client is bufferless, emulate a normal Emacs exit - ;; and offer to save all buffers. Otherwise, offer to - ;; save only the buffers belonging to the client. (save-some-buffers arg (if buffers + ;; Only files from emacsclient file list. (lambda () (memq (current-buffer) buffers)) - t)) + ;; No emacsclient file list: don't override + ;; `save-some-buffers-default-predicate' (unless + ;; ARG is non-nil), since we're not killing + ;; Emacs (unlike `save-buffers-kill-emacs'). + (and arg t))) (server-delete-client proc))) (t (error "Invalid client frame"))))) @@ -1672,7 +1694,7 @@ only these files will be asked to be saved." (save-current-buffer (dolist (buffer (buffer-list)) (set-buffer buffer) - (remove-hook 'kill-buffer-hook 'server-kill-buffer t))) + (remove-hook 'kill-buffer-hook #'server-kill-buffer t))) ;; continue standard unloading nil) @@ -1715,7 +1737,7 @@ returns the process ID of the Emacs instance running \"server\"." (server-quote-arg (format "%S" form)) "\n")) (while (memq (process-status process) '(open run)) - (accept-process-output process 0 10)) + (accept-process-output process 0.01)) (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 ". |