diff options
Diffstat (limited to 'lisp/server.el')
| -rw-r--r-- | lisp/server.el | 214 |
1 files changed, 125 insertions, 89 deletions
diff --git a/lisp/server.el b/lisp/server.el index 270eff55dcd..28e789a4c88 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -188,6 +188,13 @@ space (this means characters from ! to ~; or from code 33 to :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." + :group 'server + :type 'hook + :version "27.1") + (defcustom server-done-hook nil "Hook run when done editing a buffer for the Emacs server." :group 'server @@ -251,8 +258,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,8 +278,13 @@ changed while a server is running." ;; 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.") @@ -523,13 +543,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 @@ -621,23 +641,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))) @@ -754,9 +780,6 @@ 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 @@ -1068,9 +1091,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. @@ -1084,7 +1106,8 @@ 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 @@ -1092,16 +1115,16 @@ The following commands are accepted by the client: (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))) @@ -1109,24 +1132,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 () @@ -1137,7 +1160,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 () @@ -1147,13 +1170,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 @@ -1172,7 +1195,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")) @@ -1183,7 +1206,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))) @@ -1201,7 +1224,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))) @@ -1212,14 +1235,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))) @@ -1236,28 +1259,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 @@ -1269,16 +1293,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 @@ -1288,21 +1312,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)) + (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 (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)))))) - ;; 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))) + (mapc 'funcall (nreverse commands)) ;; Delete the client if necessary. (cond @@ -1318,9 +1350,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 @@ -1639,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"))))) |