X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/408784a7d589e1ccc6a04b7cf5f6e82e85e42ff0..27422a9d8a01ea0658d689be824936674bb20d6e:/lisp/server.el diff --git a/lisp/server.el b/lisp/server.el index d094ac815d..7256a729de 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -1,7 +1,7 @@ ;;; server.el --- Lisp code for GNU Emacs running as server process -;; Copyright (C) 1986, 87, 92, 94, 95, 96, 97, 98, 99, 2000, 2001 -;; Free Software Foundation, Inc. +;; Copyright (C) 1986, 1987, 1992, 1994, 1995, 1996, 1997, 1998, 1999, 2000, +;; 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. ;; Author: William Sommerfeld ;; Maintainer: FSF @@ -23,8 +23,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -44,10 +44,10 @@ ;; Note that any number of clients may dispatch files to emacs to be edited. ;; When you finish editing a Server buffer, again call server-edit -;; to mark that buffer as done for the client and switch to the next -;; Server buffer. When all the buffers for a client have been edited +;; to mark that buffer as done for the client and switch to the next +;; Server buffer. When all the buffers for a client have been edited ;; and exited with server-edit, the client "editor" will return -;; to the program that invoked it. +;; to the program that invoked it. ;; Your editing commands and Emacs's display output go to and from ;; the terminal in the usual way. Thus, server operation is possible @@ -69,8 +69,8 @@ ;; brought into the foreground for editing. When done editing, Emacs is ;; suspended again, and the client program is brought into the foreground. -;; The buffer local variable "server-buffer-clients" lists -;; the clients who are waiting for this buffer to be edited. +;; The buffer local variable "server-buffer-clients" lists +;; the clients who are waiting for this buffer to be edited. ;; The global variable "server-clients" lists all the waiting clients, ;; and which files are yet to be edited for each. @@ -97,10 +97,8 @@ :group 'server :type 'hook) -(defvar server-process nil - "The current server process") - -(defvar server-previous-strings nil) +(defvar server-process nil + "The current server process.") (defvar server-clients nil "List of current server clients. @@ -114,24 +112,36 @@ When a buffer is marked as \"done\", it is removed from this list.") ;; Changing major modes should not erase this local. (put 'server-buffer-clients 'permanent-local t) -(defvar server-window nil - "*The window to use for selecting Emacs server buffers. +(defcustom server-window nil + "*Specification of the window to use for selecting Emacs server buffers. If nil, use the selected window. -If it is a frame, use the frame's selected window. If it is a function, it should take one argument (a buffer) and -display and select it. A common value is `pop-to-buffer'.") +display and select it. A common value is `pop-to-buffer'. +If it is a window, use that. +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) + (not (functionp value))) + nil) + (function-item :tag "Use pop-to-buffer" pop-to-buffer) + (function :tag "Other function"))) (defcustom server-temp-file-regexp "^/tmp/Re\\|/draft$" - "*Regexp which should match filenames of temporary files -which are deleted and reused after each edit -by the programs that invoke the Emacs server." + "*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 "*Whether to kill buffers when done with them. If non-nil, kill a buffer unless it already existed before editing -it with Emacs server. If nil, kill only buffers as specified by +it with Emacs server. If nil, kill only buffers as specified by `server-temp-file-regexp'. Please note that only buffers are killed that still have a client, i.e. buffers visited which \"emacsclient --no-wait\" are never killed in @@ -149,13 +159,13 @@ 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) -(defvar server-socket-name - (format "/tmp/esrv%d-%s" (user-uid) - (substring (system-name) 0 (string-match "\\." (system-name))))) +(defvar server-name "server") + +(defvar server-socket-dir + (format "/tmp/emacs%d" (user-uid))) -;; If a *server* buffer exists, -;; write STRING to it for logging purposes. (defun server-log (string &optional client) + "If a *server* buffer exists, write STRING to it for logging purposes." (if (get-buffer "*server*") (with-current-buffer "*server*" (goto-char (point-max)) @@ -165,9 +175,6 @@ are done with it in the server.") (or (bolp) (newline))))) (defun server-sentinel (proc msg) - ;; Purge server-previous-strings of the now irrelevant entry. - (setq server-previous-strings - (delq (assq proc server-previous-strings) server-previous-strings)) (let ((client (assq proc server-clients))) ;; Remove PROC from the list of clients. (when client @@ -214,6 +221,22 @@ are done with it in the server.") (t " "))) 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: +- there's no symlink involved +- it's owned by us +- it's not readable/writable by anybody else." + (setq dir (directory-file-name dir)) + (let ((attrs (file-attributes dir))) + (unless attrs + (letf (((default-file-modes) ?\700)) (make-directory dir)) + (setq attrs (file-attributes dir))) + ;; Check that it's safe for use. + (unless (and (eq t (car attrs)) (eq (nth 2 attrs) (user-uid)) + (zerop (logand ?\077 (file-modes dir)))) + (error "The directory %s is unsafe" dir)))) + ;;;###autoload (defun server-start (&optional leave-dead) "Allow this Emacs process to be a server for client processes. @@ -224,10 +247,15 @@ Emacs distribution as your standard \"editor\". Prefix arg means just kill any existing server communications subprocess." (interactive "P") + ;; Make sure there is a safe directory in which to place the socket. + (server-ensure-safe-dir server-socket-dir) ;; kill it dead! - (condition-case () (delete-process server-process) (error nil)) + (if server-process + (condition-case () (delete-process server-process) (error nil))) ;; Delete the socket files made by previous server invocations. - (condition-case () (delete-file server-socket-name) (error nil)) + (condition-case () + (delete-file (expand-file-name server-name server-socket-dir)) + (error nil)) ;; If this Emacs already had a server, clear out associated status. (while server-clients (let ((buffer (nth 1 (car server-clients)))) @@ -235,29 +263,38 @@ Prefix arg means just kill any existing server communications subprocess." (unless leave-dead (if server-process (server-log (message "Restarting server"))) - (let ((umask (default-file-modes))) - (unwind-protect - (progn - (set-default-file-modes ?\700) - (setq server-process - (make-network-process - :name "server" :family 'local :server t :noquery t - :service server-socket-name - :sentinel 'server-sentinel :filter 'server-process-filter - ;; We must receive file names without being decoded. - ;; Those are decoded by server-process-filter according - ;; to file-name-coding-system. - :coding 'raw-text))) - (set-default-file-modes umask))))) + (letf (((default-file-modes) ?\700)) + (setq server-process + (make-network-process + :name "server" :family 'local :server t :noquery t + :service (expand-file-name server-name server-socket-dir) + :sentinel 'server-sentinel :filter 'server-process-filter + ;; We must receive file names without being decoded. + ;; Those are decoded by server-process-filter according + ;; to file-name-coding-system. + :coding 'raw-text))))) + +;;;###autoload +(define-minor-mode server-mode + "Toggle Server mode. +With ARG, turn Server mode on if ARG is positive, off otherwise. +Server mode runs a process that accepts commands from the +`emacsclient' program. See `server-start' and Info node `Emacs server'." + :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)? + (server-start (not server-mode))) -;Process a request from the server to edit some files. -;Format of STRING is "PATH PATH PATH... \n" (defun server-process-filter (proc string) + "Process a request from the server to edit some files. +PROC is the server process. Format of STRING is \"PATH PATH PATH... \\n\"." (server-log string proc) - (let ((ps (assq proc server-previous-strings))) - (when (cdr ps) - (setq string (concat (cdr ps) string)) - (setcdr ps nil))) + (let ((prev (process-get proc 'previous-string))) + (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) @@ -268,13 +305,13 @@ Prefix arg means just kill any existing server communications subprocess." client nowait eval (files nil) (lineno 1) + (tmp-frame nil) ; Sometimes used to embody the selected display. (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)))) - (pos 0)) + (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)) @@ -283,16 +320,16 @@ Prefix arg means just kill any existing server communications subprocess." (let ((display (server-unquote-arg (match-string 1 request)))) (setq request (substring request (match-end 0))) (condition-case err - (server-select-display display) + (setq tmp-frame (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)))) + (setq lineno (string-to-number (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)))) + (setq lineno (string-to-number (match-string 1 arg)) + columnno (string-to-number (match-string 2 arg)))) (t ;; Undo the quoting that emacsclient does ;; for certain special characters. @@ -306,7 +343,12 @@ Prefix arg means just kill any existing server communications subprocess." (with-temp-buffer (let ((standard-output (current-buffer))) (pp v) - (process-send-region proc (point-min) (point-max)))))) + ;; Suppress the error rose when the pipe to PROC is closed. + (condition-case err + (process-send-region proc (point-min) (point-max)) + (file-error nil) + (error nil)) + )))) ;; ARG is a file name. ;; Collapse multiple slashes to single slashes. (setq arg (command-line-normalize-file-name arg)) @@ -325,16 +367,17 @@ Prefix arg means just kill any existing server communications subprocess." (server-log "Close empty client" proc)) ;; We visited some buffer for this client. (or nowait (push client server-clients)) - (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]")))))) + (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]"))))) + ;; Avoid preserving the connection after the last real frame is deleted. + (if tmp-frame (delete-frame tmp-frame)))) ;; Save for later any partial line that remains. (when (> (length string) 0) - (let ((ps (assq proc server-previous-strings))) - (if ps (setcdr ps string) - (push (cons proc string) server-previous-strings))))) + (process-put proc 'previous-string string))) (defun server-goto-line-column (file-line-col) (goto-line (nth 1 file-line-col)) @@ -520,7 +563,7 @@ inhibits a backup; you can set it locally in a particular buffer to prevent a backup for it.) The variable `server-temp-file-regexp' controls which filenames are considered temporary. -If invoked with a prefix argument, or if there is no server process running, +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") (if (or arg @@ -582,13 +625,17 @@ Arg NEXT-BUFFER is a suggestion; if it is a live buffer, use it." ;; a minibuffer/dedicated-window (if there's no other). (error (pop-to-buffer next-buffer))))))))) -(global-set-key "\C-x#" 'server-edit) +(define-key ctl-x-map "#" 'server-edit) (defun server-unload-hook () + (server-start t) (remove-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function) (remove-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function) (remove-hook 'kill-buffer-hook 'server-kill-buffer)) + +(add-hook 'server-unload-hook 'server-unload-hook) (provide 'server) +;;; arch-tag: 1f7ecb42-f00a-49f8-906d-61995d84c8d6 ;;; server.el ends here