diff options
Diffstat (limited to 'lisp/server.el')
| -rw-r--r-- | lisp/server.el | 379 |
1 files changed, 295 insertions, 84 deletions
diff --git a/lisp/server.el b/lisp/server.el index a6b2742190f..aac3da13e4f 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -106,6 +106,24 @@ Each element is (CLIENTID BUFFERS...) where CLIENTID is a string that can be given to the server process to identify a client. When a buffer is marked as \"done\", it is removed from this list.") +(defvar server-ttys nil + "List of current terminal devices used by the server. +Each element is (CLIENTID TTY) where CLIENTID is a string +that can be given to the server process to identify a client. +TTY is the name of the tty device. + +When all frames on the device are deleted, the server quits the +connection to the client, and vice versa.") + +(defvar server-frames nil + "List of current window-system frames used by the server. +Each element is (CLIENTID FRAME) where CLIENTID is a string +that can be given to the server process to identify a client. +FRAME is the frame that was opened by the client. + +When the frame is deleted, the server closes the connection to +the client, and vice versa.") + (defvar server-buffer-clients nil "List of client ids for clients requesting editing of current buffer.") (make-variable-buffer-local 'server-buffer-clients) @@ -168,10 +186,18 @@ are done with it in the server.") (with-current-buffer "*server*" (goto-char (point-max)) (insert (current-time-string) - (if client (format " %s:" client) " ") + (if client (format " %s: " client) " ") string) (or (bolp) (newline))))) +(defun server-tty-live-p (tty) + "Return non-nil if the tty device named TTY has a live frame." + (let (result) + (dolist (frame (frame-list) result) + (when (and (eq (frame-live-p frame) t) + (equal (frame-tty-name frame) tty)) + (setq result t))))) + (defun server-sentinel (proc msg) (let ((client (assq proc server-clients))) ;; Remove PROC from the list of clients. @@ -186,9 +212,54 @@ are done with it in the server.") (or (and server-kill-new-buffers (not server-existing-buffer)) (server-temp-file-p))) - (kill-buffer (current-buffer))))))) + (kill-buffer (current-buffer))))) + (let ((tty (assq (car client) server-ttys))) + (when tty + (setq server-ttys (delq tty server-ttys)) + (when (server-tty-live-p (cadr tty)) + (delete-tty (cadr tty))))))) (server-log (format "Status changed to %s" (process-status proc)) proc)) +(defun server-handle-delete-tty (tty) + "Delete the client connection when the emacsclient terminal device is closed." + (dolist (entry server-ttys) + (let ((proc (nth 0 entry)) + (term (nth 1 entry))) + (when (equal term tty) + (let ((client (assq proc server-clients))) + (server-log (format "server-handle-delete-tty, tty %s" tty) (car client)) + (setq server-ttys (delq entry server-ttys)) + (delete-process (car client)) + (when (assq proc server-clients) + ;; This seems to be necessary to handle + ;; `emacsclient -t -e '(delete-frame)'' correctly. + (setq server-clients (delq client server-clients)))))))) + +(defun server-handle-suspend-tty (tty) + "Notify the emacsclient process to suspend itself when its tty device is suspended." + (dolist (entry server-ttys) + (let ((proc (nth 0 entry)) + (term (nth 1 entry))) + (when (equal term tty) + (let ((process (car (assq proc server-clients)))) + (server-log (format "server-handle-suspend-tty, tty %s" tty) process) + (process-send-string process "-suspend \n")))))) + +(defun server-handle-delete-frame (frame) + "Delete the client connection when the emacsclient frame is deleted." + (dolist (entry server-frames) + (let ((proc (nth 0 entry)) + (f (nth 1 entry))) + (when (equal frame f) + (let ((client (assq proc server-clients))) + (server-log (format "server-handle-delete-frame, frame %s" frame) (car client)) + (setq server-frames (delq entry server-frames)) + (delete-process (car client)) + (when (assq proc server-clients) + ;; This seems to be necessary to handle + ;; `emacsclient -t -e '(delete-frame)'' correctly. + (setq server-clients (delq client server-clients)))))))) + (defun server-select-display (display) ;; If the current frame is on `display' we're all set. (unless (equal (frame-parameter (selected-frame) 'display) display) @@ -200,14 +271,14 @@ are done with it in the server.") ;; and select it. (unless (equal (frame-parameter (selected-frame) 'display) display) (select-frame - (make-frame-on-display - display + (make-frame-on-display display))))) ;; This frame is only there in place of an actual "current display" ;; setting, so we want it to be as unobtrusive as possible. That's ;; what the invisibility is for. The minibuffer setting is so that ;; we don't end up displaying a buffer in it (which noone would ;; notice). - '((visibility . nil) (minibuffer . only))))))) + ;; XXX I have found this behaviour to be surprising and annoying. -- Lorentey + ;; '((visibility . nil) (minibuffer . only))))))) (defun server-unquote-arg (arg) (replace-regexp-in-string @@ -219,6 +290,19 @@ are done with it in the server.") (t " "))) arg t t)) +(defun server-quote-arg (arg) + "In NAME, insert a & before each &, each space, each newline, and -. +Change spaces to underscores, too, so that the return value never +contains a space." + (replace-regexp-in-string + "[-&\n ]" (lambda (s) + (case (aref s 0) + (?& "&&") + (?- "&-") + (?\n "&n") + (?\s "&_"))) + arg t t)) + (defun server-ensure-safe-dir (dir) "Make sure DIR is a directory with no race-condition issues. Creates the directory if necessary and makes sure: @@ -256,10 +340,18 @@ Prefix arg means just kill any existing server communications subprocess." (while server-clients (let ((buffer (nth 1 (car server-clients)))) (server-buffer-done buffer))) + ;; Delete any remaining opened frames of the previous server. + (while server-ttys + (let ((tty (cadar server-ttys))) + (setq server-ttys (cdr server-ttys)) + (when (server-tty-live-p tty) (delete-tty tty)))) (unless leave-dead (if server-process (server-log (message "Restarting server"))) (letf (((default-file-modes) ?\700)) + (add-to-list 'delete-tty-after-functions 'server-handle-delete-tty) + (add-to-list 'suspend-tty-functions 'server-handle-suspend-tty) + (add-to-list 'delete-frame-functions 'server-handle-delete-frame) (setq server-process (make-network-process :name "server" :family 'local :server t :noquery t @@ -291,81 +383,186 @@ PROC is the server process. Format of STRING is \"PATH PATH PATH... \\n\"." (when prev (setq string (concat prev string)) (process-put proc 'previous-string nil))) - ;; If the input is multiple lines, - ;; process each line individually. - (while (string-match "\n" 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 nowait eval - (files nil) - (lineno 1) - (columnno 0)) - ;; Remove this line from STRING. - (setq string (substring string (match-end 0))) - (setq client (cons proc nil)) - (while (string-match "[^ ]* " request) - (let ((arg (substring request (match-beginning 0) (1- (match-end 0))))) - (setq request (substring request (match-end 0))) - (cond - ((equal "-nowait" arg) (setq nowait t)) - ((equal "-eval" arg) (setq eval t)) - ((and (equal "-display" arg) (string-match "\\([^ ]*\\) " request)) - (let ((display (server-unquote-arg (match-string 1 request)))) - (setq request (substring request (match-end 0))) - (condition-case err - (server-select-display display) - (error (process-send-string proc (nth 1 err)) - (setq request ""))))) - ;; ARG is a line number option. - ((string-match "\\`\\+[0-9]+\\'" arg) - (setq lineno (string-to-int (substring arg 1)))) - ;; ARG is line number:column option. - ((string-match "\\`+\\([0-9]+\\):\\([0-9]+\\)\\'" arg) - (setq lineno (string-to-int (match-string 1 arg)) - columnno (string-to-int (match-string 2 arg)))) - (t - ;; Undo the quoting that emacsclient does - ;; for certain special characters. - (setq arg (server-unquote-arg arg)) - ;; Now decode the file name if necessary. - (if coding-system - (setq arg (decode-coding-string arg coding-system))) - (if eval - (let ((v (eval (car (read-from-string arg))))) - (when v - (with-temp-buffer - (let ((standard-output (current-buffer))) - (pp v) - (process-send-region proc (point-min) (point-max)))))) - ;; ARG is a file name. - ;; Collapse multiple slashes to single slashes. - (setq arg (command-line-normalize-file-name arg)) - (push (list arg lineno columnno) files)) - (setq lineno 1) - (setq columnno 0))))) - (when files - (run-hooks 'pre-command-hook) - (server-visit-files files client nowait) - (run-hooks 'post-command-hook)) - ;; CLIENT is now a list (CLIENTNUM BUFFERS...) - (if (null (cdr client)) - ;; This client is empty; get rid of it immediately. - (progn - (delete-process proc) - (server-log "Close empty client" proc)) - ;; We visited some buffer for this client. - (or nowait (push client server-clients)) - (unless (or isearch-mode (minibufferp)) - (server-switch-buffer (nth 1 client)) - (run-hooks 'server-switch-hook) - (unless nowait - (message (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))) + (condition-case err + (progn + ;; If the input is multiple lines, + ;; process each line individually. + (while (string-match "\n" 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 nowait newframe display version-checked + dontkill ; t if the client should not be killed. + registered ; t if the client is already added to server-clients. + (files nil) + (lineno 1) + (columnno 0)) + ;; Remove this line from STRING. + (setq string (substring string (match-end 0))) + (setq client (cons proc nil)) + (while (string-match "[^ ]* " request) + (let ((arg (substring request (match-beginning 0) (1- (match-end 0))))) + (setq request (substring request (match-end 0))) + (cond + ;; Check version numbers. + ((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 + (process-send-string proc "-good-version \n") + (setq version-checked t)) + (error (concat "Version mismatch: Emacs is " truncated-emacs-version ", emacsclient is " client-version))))) + + ((equal "-nowait" arg) (setq nowait t)) + + ((and (equal "-display" arg) (string-match "\\([^ ]*\\) " request)) + (setq display (match-string 1 request) + request (substring request (match-end 0)))) + + ;; Open a new X frame. + ((equal "-window-system" arg) + (unless version-checked + (error "Protocol error; make sure to use the correct version of emacsclient")) + (let ((frame (make-frame-on-display + (or display + (frame-parameter nil 'display) + (getenv "DISPLAY") + (error "Please specify display"))))) + (push (list proc frame) server-frames) + (select-frame frame) + ;; This makes sure that `emacsclient -w -e '(delete-frame)'' works right. + (push client server-clients) + (setq registered t + newframe t + dontkill t))) + + ;; Resume a suspended tty frame. + ((equal "-resume" arg) + (let ((tty (cadr (assq (car client) server-ttys)))) + (setq dontkill t) + (when tty (resume-tty tty)))) + + ;; 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 ((tty (cadr (assq (car client) server-ttys)))) + (setq dontkill t) + (when tty (suspend-tty tty)))) + + ;; Noop; useful for debugging emacsclient. + ((and (equal "-ignore" arg) (string-match "\\([^ ]*\\) " request)) + (setq dontkill t + request (substring request (match-end 0)))) + + ;; Open a new tty frame at the client. ARG is the name of the pseudo tty. + ((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 version-checked + (error "Protocol error; make sure to use the correct version of emacsclient")) + (let ((frame (make-frame-on-tty tty type))) + (push (list (car client) (frame-tty-name frame)) server-ttys) + (process-send-string proc (concat "-emacs-pid " (number-to-string (emacs-pid)) "\n")) + (select-frame frame) + ;; This makes sure that `emacsclient -t -e '(delete-frame)'' works right. + (push client server-clients) + (setq registered t + dontkill t + newframe t)))) + + ;; ARG is a line number option. + ((and (equal "-position" arg) (string-match "\\(\\+[0-9]+\\) " request)) + (setq request (substring request (match-end 0)) + lineno (string-to-int (substring (match-string 1 request) 1)))) + + ;; ARG is line number:column option. + ((and (equal "-position" arg) (string-match "\\+\\([0-9]+\\):\\([0-9]+\\) " request)) + (setq request (substring request (match-end 0)) + lineno (string-to-int (match-string 1 request)) + columnno (string-to-int (match-string 2 request)))) + + ;; ARG is a file to load. + ((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)) + (setq lineno 1 + columnno 0)) + + ;; ARG is a Lisp expression. + ((and (equal "-eval" arg) (string-match "\\([^ ]+\\) " request)) + (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 newframe) v) + (with-temp-buffer + (let ((standard-output (current-buffer))) + (pp v) + (process-send-string proc "-print ") + (process-send-string + proc (server-quote-arg + (buffer-substring-no-properties (point-min) + (point-max)))) + (process-send-string proc "\n"))))) + (setq lineno 1 + columnno 0))) + + ;; Unknown command. + (t (error "Unknown command: %s" arg))))) + + (when files + (run-hooks 'pre-command-hook) + (server-visit-files files client nowait) + (run-hooks 'post-command-hook)) + + ;; CLIENT is now a list (CLIENTNUM BUFFERS...) + + ;; Delete the client if necessary. + (cond + ;; Client requested nowait; return immediately. + (nowait + (delete-process proc) + (server-log "Close nowait client" proc)) + ;; This client is empty; get rid of it immediately. + ((and (not dontkill) (null (cdr client))) + (delete-process proc) + (server-log "Close empty client" proc)) + ((not registered) + (push client server-clients))) + + ;; We visited some buffer for this client. + (cond + ((or isearch-mode (minibufferp)) + nil) + ((and newframe (null (cdr client))) + (message (substitute-command-keys + "When done with this frame, type \\[delete-frame]"))) + ((not (null (cdr client))) + (server-switch-buffer (nth 1 client)) + (run-hooks 'server-switch-hook) + (unless nowait + (message (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))) + ;; condition-case + (error (ignore-errors + (process-send-string + proc (concat "-error " (server-quote-arg (error-message-string err)))) + (setq string "") + (server-log (error-message-string err) proc) + (delete-process proc))))) (defun server-goto-line-column (file-line-col) (goto-line (nth 1 file-line-col)) @@ -439,9 +636,17 @@ FOR-KILLING if non-nil indicates that we are called from `kill-buffer'." ;; If client now has no pending buffers, ;; tell it that it is done, and forget it entirely. (unless (cdr client) - (delete-process (car client)) - (server-log "Close" (car client)) - (setq server-clients (delq client server-clients)))) + (let ((tty (cadr (assq (car client) server-ttys))) + (frame (cadr (assq (car client) server-frames)))) + (cond + ;; Be careful, if we delete the process before the + ;; tty, then the terminal modes will not be restored + ;; correctly. + (tty (delete-tty tty)) + (frame (delete-frame frame)) + (t (delete-process (car client)) + (server-log "Close" (car client)) + (setq server-clients (delq client server-clients))))))) (setq old-clients (cdr old-clients))) (if (and (bufferp buffer) (buffer-name buffer)) ;; We may or may not kill this buffer; @@ -508,6 +713,11 @@ specifically for the clients and did not exist before their request for it." ;; using whatever is on disk in that file. -- rms. (defun server-kill-buffer-query-function () (or (not server-buffer-clients) + (let ((res t)) + (dolist (proc server-buffer-clients res) + (setq proc (assq proc server-clients)) + (when (and proc (eq (process-status (car proc)) 'open)) + (setq res nil)))) (yes-or-no-p (format "Buffer `%s' still has clients; kill it? " (buffer-name (current-buffer)))))) @@ -569,7 +779,8 @@ Arg NEXT-BUFFER is a suggestion; if it is a live buffer, use it." ;; since we've already effectively done that. (if (null next-buffer) (if server-clients - (server-switch-buffer (nth 1 (car server-clients)) killed-one) + (let ((buffer (nth 1 (car server-clients)))) + (and buffer (server-switch-buffer buffer killed-one))) (unless (or killed-one (window-dedicated-p (selected-window))) (switch-to-buffer (other-buffer)) (message "No server buffers remain to edit"))) |