-;;; 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 Free Software Foundation, Inc.
+;; Copyright (C) 1986-1987, 1992, 1994-2011 Free Software Foundation, Inc.
;; Author: William Sommerfeld <wesommer@athena.mit.edu>
;; Maintainer: FSF
(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."
+ :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."
+ "Directory for server authentication files.
+
+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
(put 'server-auth-dir 'risky-local-variable t)
(defcustom server-raise-frame t
it with the Emacs server. If nil, kill only buffers as specified by
`server-temp-file-regexp'.
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."
+i.e. buffers visited with \"emacsclient --no-wait\" are never killed
+in this way."
:group 'server
:type 'boolean
:version "21.1")
are done with it in the server.")
(make-variable-buffer-local 'server-existing-buffer)
-(defvar server-name "server")
+(defcustom server-name "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."
+ :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
- (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid))
- "The directory in which to place the server socket.")
+ (and (featurep 'make-network-process '(:family local))
+ (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.")
(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.
`(let ((process-environment process-environment))
(dolist (,var ,vars)
(let ((,value (getenv-internal ,var ,env)))
- (push (if (null ,value)
- ,var
- (concat ,var "=" ,value))
+ (push (if (stringp ,value)
+ (concat ,var "=" ,value)
+ ,var)
process-environment)))
(progn ,@body))))
(defun server-delete-client (proc &optional noframe)
"Delete PROC, including its buffers, terminals and frames.
-If NOFRAME is non-nil, let the frames live. (To be used from
-`delete-frame-functions'.)"
+If NOFRAME is non-nil, let the frames live.
+Updates `server-clients'."
(server-log (concat "server-delete-client" (if noframe " noframe")) proc)
;; Force a new lookup of client (prevents infinite recursion).
(when (memq proc server-clients)
(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)))))
(process-query-on-exit-flag proc))
(set-process-query-on-exit-flag proc nil))
;; Delete the associated connection file, if applicable.
- ;; This is actually problematic: the file may have been overwritten by
- ;; another Emacs server in the mean time, so it's not ours any more.
- ;; (and (process-contact proc :server)
- ;; (eq (process-status proc) 'closed)
- ;; (ignore-errors (delete-file (process-get proc :server-file))))
+ ;; Although there's no 100% guarantee that the file is owned by the
+ ;; running Emacs instance, server-start uses server-running-p to check
+ ;; for possible servers before doing anything, so it *should* be ours.
+ (and (process-contact proc :server)
+ (eq (process-status proc) 'closed)
+ (ignore-errors
+ (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-select-display (display)
;; If the current frame is on `display' we're all set.
- ;; Similarly if we are unable to open a frames on other displays, there's
+ ;; 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))
(set-frame-parameter frame 'server-dummy-buffer nil)))
(defun server-handle-delete-frame (frame)
- "Delete the client connection when the emacsclient frame is deleted."
+ "Delete the client connection when the emacsclient frame is deleted.
+\(To be used from `delete-frame-functions'.)"
(let ((proc (frame-parameter frame 'client)))
(when (and (frame-live-p frame)
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))))))
arg t t))
(defun server-send-string (proc string)
- "A wrapper around `proc-send-string' for logging."
+ "A wrapper around `process-send-string' for logging."
(server-log (concat "Sent " string) proc)
(process-send-string proc string))
- it's owned by us
- it's not readable/writable by anybody else."
(setq dir (directory-file-name dir))
- (let ((attrs (file-attributes dir)))
+ (let ((attrs (file-attributes dir 'integer)))
(unless attrs
(letf (((default-file-modes) ?\700)) (make-directory dir t))
- (setq attrs (file-attributes dir)))
+ (setq attrs (file-attributes dir 'integer)))
+
;; Check that it's safe for use.
- (unless (and (eq t (car attrs)) (eql (nth 2 attrs) (user-uid))
- (or (eq system-type 'windows-nt)
- (zerop (logand ?\077 (file-modes dir)))))
- (error "The directory %s is unsafe" dir))))
+ (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.
+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 (or (= uid (user-uid)) ; is the dir ours?
+ (and w32
+ ;; Files created on Windows by
+ ;; Administrator (RID=500) have
+ ;; the Administrators (RID=544)
+ ;; group recorded as the owner.
+ (= uid 544) (= (user-uid) 500)))
+ (throw :safe nil))
+ (when w32 ; on NTFS?
+ (throw :safe t))
+ (unless (zerop (logand ?\077 (file-modes dir)))
+ (throw :safe nil))
+ t)))
+ (unless safe
+ (error "The directory `%s' is unsafe" dir)))))
;;;###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
Emacs distribution as your standard \"editor\".
Optional argument LEAVE-DEAD (interactively, a prefix arg) means just
-kill any existing server communications subprocess."
+kill any existing server communications subprocess.
+
+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")
- (when (or
- (not server-clients)
- (yes-or-no-p
- "The current server still has clients; delete them? "))
- (when server-process
- ;; kill it dead!
- (ignore-errors (delete-process server-process)))
- ;; Delete the socket files made by previous server invocations.
- (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
- (server-delete-client (car server-clients)))
- ;; Now any previous server is properly stopped.
- (if leave-dead
- (progn
- (server-log (message "Server stopped"))
- (setq server-process nil))
- (let* ((server-dir (if server-use-tcp server-auth-dir server-socket-dir))
- (server-file (expand-file-name server-name server-dir)))
+ (when (or (not server-clients)
+ ;; 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.
+ (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
+ ;; 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)
+ "To start the server in this Emacs process, stop the existing
+server or call `M-x server-force-delete' to forcibly disconnect it.")
+ :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)))
+ ;; Now any previous server is properly stopped.
+ (if leave-dead
+ (progn
+ (unless (eq t leave-dead) (server-log (message "Server stopped")))
+ (setq server-process nil))
;; Make sure there is a safe directory in which to place the socket.
(server-ensure-safe-dir server-dir)
- ;; Remove any leftover socket or authentication file.
- (ignore-errors (delete-file server-file))
(when server-process
(server-log (message "Restarting server")))
(letf (((default-file-modes) ?\700))
(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
:coding 'raw-text-unix
;; The other args depend on the kind of socket used.
(if server-use-tcp
- (list :family nil
- :service t
+ (list :family 'ipv4 ;; We're not ready for IPv6 yet
+ :service (or server-port t)
:host (or server-host 'local)
:plist '(:authenticated nil))
(list :family 'local
:service server-file
:plist '(:authenticated t)))))
(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 `!'..`~'.
- for i below 64
- collect (+ 33 (random 94)) into auth
- finally return (concat auth))))
+ ;; 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))))
(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-running-p (&optional name)
- "Test whether server NAME is running."
+(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.
+If server is running, it is first stopped.
+NAME defaults to `server-name'. With argument, ask for NAME."
(interactive
(list (if current-prefix-arg
(read-string "Server name: " nil nil server-name))))
+ (when server-mode (with-temp-message nil (server-mode -1)))
+ (let ((file (expand-file-name (or name server-name)
+ (if server-use-tcp
+ server-auth-dir
+ server-socket-dir))))
+ (condition-case nil
+ (let (delete-by-moving-to-trash)
+ (delete-file file)
+ (message "Connection file %S deleted" file))
+ (file-error
+ (message "No connection file %S" file)))))
+
+(defun server-running-p (&optional name)
+ "Test whether server NAME is running.
+
+Return values:
+ nil the server is definitely not running.
+ t the server seems to be running.
+ something else we cannot determine whether it's running without using
+ commands which may have to wait for a long time."
(unless name (setq name server-name))
(condition-case nil
- (progn
+ (if server-use-tcp
+ (with-temp-buffer
+ (insert-file-contents-literally (expand-file-name name server-auth-dir))
+ (or (and (looking-at "127\\.0\\.0\\.1:[0-9]+ \\([0-9]+\\)")
+ (assq 'comm
+ (process-attributes
+ (string-to-number (match-string 1))))
+ t)
+ :other))
(delete-process
(make-network-process
:name "server-client-test" :family 'local :server nil :noquery t
(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)
+ (when proc
(with-temp-buffer
(let ((standard-output (current-buffer)))
(pp v)
(server-quote-arg text)))))))))
(defun server-create-tty-frame (tty type proc)
+ (unless tty
+ (error "Invalid terminal device"))
+ (unless type
+ (error "Invalid terminal type"))
(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-on-tty tty 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.
;; 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)
+(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
;; killing emacs on that frame.
(let* ((params `((client . ,(if nowait 'nowait proc))
;; This is a leftover, see above.
- (environment . ,(process-get proc 'env))))
- (frame (make-frame-on-display
- (or display
- (frame-parameter nil 'display)
- (getenv "DISPLAY")
- (error "Please specify display"))
- params)))
+ (environment . ,(process-get proc 'env))
+ ,@parameters))
+ (display (or display
+ (frame-parameter nil 'display)
+ (getenv "DISPLAY")
+ (error "Please specify display")))
+ frame)
+ (if parent-id
+ (push (cons 'parent-id (string-to-number parent-id)) params))
+ (setq frame (make-frame-on-display display params))
(server-log (format "%s created" frame) proc)
(select-frame frame)
(process-put proc 'frame frame)
(switch-to-buffer (get-buffer-create "*scratch*") 'norecord)
frame)))
-
(defun server-goto-toplevel (proc)
(condition-case nil
;; If we're running isearch, we must abort it to allow Emacs to
;; 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:
(defun* server-process-filter (proc string)
"Process a request from the server to edit some files.
PROC is the server process. STRING consists of a sequence of
-commands prefixed by a dash. Some commands have arguments; these
-are &-quoted and need to be decoded by `server-unquote-arg'. The
-filter parses and executes these commands.
+commands prefixed by a dash. Some commands have arguments;
+these are &-quoted and need to be decoded by `server-unquote-arg'.
+The filter parses and executes these commands.
To illustrate the protocol, here is an example command that
emacsclient sends to create a new X frame (note that the whole
sequence is sent on a single line):
- -env HOME /home/lorentey
- -env DISPLAY :0.0
+ -env HOME=/home/lorentey
+ -env DISPLAY=:0.0
... lots of other -env commands
-display :0.0
-window-system
`-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.
controlling tty.
`-ignore COMMENT'
- Do nothing, but put the comment in the server
- log. Useful for debugging.
+ Do nothing, but put the comment in the server log.
+ Useful for debugging.
The following commands are accepted by the client:
returned by -eval.
`-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.
(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)))
(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)
;; supported any more.
(assert (eq (match-end 0) (length string)))
(let ((request (substring string 0 (match-beginning 0)))
- (coding-system (and default-enable-multibyte-characters
+ (coding-system (and (default-value 'enable-multibyte-characters)
(or file-name-coding-system
default-file-name-coding-system)))
- nowait ; t if emacsclient does not want to wait for us.
- frame ; The frame that was opened for the client (if any).
- display ; Open the frame on this display.
- dontkill ; t if the client should not be killed.
+ 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.
+ parent-id ; Window ID for XEmbed
+ dontkill ; t if client should not be killed.
commands
dir
use-current-frame
- tty-name ;nil, `window-system', or the tty name.
- tty-type ;string.
+ 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)))
-
- ;; -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 (command-line-normalize-file-name file))
- (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"
+ (setq dontkill t)
+ (setq 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 at the client.
+ (`"-tty"
+ (setq tty-name (pop args-left)
+ tty-type (pop args-left)
+ dontkill (or dontkill
+ (not use-current-frame))))
+
+ ;; -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))))
(setq frame
(cond
;; We can't use the Emacs daemon's
;; terminal frame.
(not (and (daemonp)
- (= (length (frame-list)) 1)
+ (null (cdr (frame-list)))
(eq (selected-frame)
terminal-frame)))))
(setq tty-name nil tty-type nil)
(if display (server-select-display display)))
((eq tty-name 'window-system)
- (server-create-window-system-frame display nowait proc))
+ (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
- (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))
(error (server-return-error proc err))))
(defun server-execute (proc files nowait commands dontkill frame tty-name)
- (condition-case err
- (let* ((buffers
- (when files
- (run-hooks 'pre-command-hook)
- (prog1 (server-visit-files files proc nowait)
- (run-hooks 'post-command-hook)))))
-
- (mapc 'funcall (nreverse commands))
-
- ;; Delete the client if necessary.
- (cond
- (nowait
- ;; Client requested nowait; return immediately.
- (server-log "Close nowait client" proc)
- (server-delete-client proc))
- ((and (not dontkill) (null buffers))
- ;; This client is empty; get rid of it immediately.
- (server-log "Close empty client" proc)
- (server-delete-client proc)))
- (cond
- ((or isearch-mode (minibufferp))
- nil)
- ((and frame (null buffers))
- (message "%s" (substitute-command-keys
- "When done with this frame, type \\[delete-frame]")))
- ((not (null buffers))
- (server-switch-buffer (car buffers) nil (cdr (car files)))
- (run-hooks 'server-switch-hook)
- (unless nowait
+ ;; 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
+ ;; user running `emacsclient'. So it is OK to override the
+ ;; inhibit-quit flag, which is good since `commands' (as well as
+ ;; find-file-noselect via the major-mode) can run arbitrary code,
+ ;; including code that needs to wait.
+ (with-local-quit
+ (condition-case err
+ (let* ((buffers
+ (when files
+ (server-visit-files files proc nowait))))
+
+ (mapc 'funcall (nreverse commands))
+
+ ;; Delete the client if necessary.
+ (cond
+ (nowait
+ ;; Client requested nowait; return immediately.
+ (server-log "Close nowait client" proc)
+ (server-delete-client proc))
+ ((and (not dontkill) (null buffers))
+ ;; This client is empty; get rid of it immediately.
+ (server-log "Close empty client" proc)
+ (server-delete-client proc)))
+ (cond
+ ((or isearch-mode (minibufferp))
+ nil)
+ ((and frame (null buffers))
(message "%s" (substitute-command-keys
- "When done with a buffer, type \\[server-edit]")))))
- (when (and frame (null tty-name))
- (server-unselect-display frame)))
- (error (server-return-error proc err))))
+ "When done with this frame, type \\[delete-frame]")))
+ ((not (null buffers))
+ (server-switch-buffer (car buffers) nil (cdr (car files)))
+ (run-hooks 'server-switch-hook)
+ (unless nowait
+ (message "%s" (substitute-command-keys
+ "When done with a buffer, type \\[server-edit]")))))
+ (when (and frame (null tty-name))
+ (server-unselect-display frame)))
+ ((quit error)
+ (when (eq (car err) 'quit)
+ (message "Quit emacsclient request"))
+ (server-return-error proc err)))))
(defun server-return-error (proc err)
(ignore-errors
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)
"Move point to the position indicated in LINE-COL.
LINE-COL should be a pair (LINE . COL)."
(when line-col
- (goto-line (car line-col))
+ (goto-char (point-min))
+ (forward-line (1- (car line-col)))
(let ((column-number (cdr line-col)))
(when (> column-number 0)
(move-to-column (1- column-number))))))
(obuf (get-file-buffer filen)))
(add-to-history 'file-name-history filen)
(if (null obuf)
- (set-buffer (find-file-noselect filen))
+ (progn
+ (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)
(cond ((file-exists-p filen)
(when (not (verify-visited-file-modtime obuf))
(revert-buffer t nil)))
(unless server-buffer-clients
(setq server-existing-buffer t)))
(server-goto-line-column (cdr file))
- (run-hooks 'server-visit-hook))
+ (run-hooks 'server-visit-hook)
+ ;; hooks may be specific to current buffer:
+ (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)
(process-put proc 'buffers
(nconc (process-get proc 'buffers) client-record)))
client-record))
-\f
+
+(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).
(not server-existing-buffer)))
(setq killed t)
(bury-buffer buffer)
+ ;; Prevent kill-buffer from prompting (Bug#3696).
+ (with-current-buffer buffer
+ (set-buffer-modified-p nil))
(kill-buffer buffer))
(unless killed
(if (server-temp-file-p buffer)
(progn
+ (with-current-buffer buffer
+ (set-buffer-modified-p nil))
(kill-buffer buffer)
(setq killed t))
(bury-buffer buffer)))))))
The variable `server-temp-file-regexp' controls which filenames
are considered temporary."
(and (buffer-file-name buffer)
- (string-match server-temp-file-regexp (buffer-file-name buffer))))
+ (string-match-p server-temp-file-regexp (buffer-file-name buffer))))
(defun server-done ()
"Offer to save current buffer, mark it as \"done\" for clients.
"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))))))
"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'."
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.
(select-frame-set-input-focus (window-frame (selected-window))))))
;;;###autoload
-(defun server-save-buffers-kill-terminal (proc &optional arg)
+(defun server-save-buffers-kill-terminal (arg)
;; Called from save-buffers-kill-terminal in files.el.
- "Offer to save each buffer, then kill PROC.
-
-With prefix arg, silently save all file-visiting buffers, then kill.
+ "Offer to save each buffer, then kill the current client.
+With ARG non-nil, silently save all file-visiting buffers, then kill.
If emacsclient was started with a list of filenames to edit, then
only these files will be asked to be saved."
- ;; save-buffers-kill-terminal occasionally calls us with proc set
- ;; to `nowait' (comes from the value of the `client' frame parameter).
- (when (processp proc)
- (let ((buffers (process-get proc 'buffers)))
- ;; If client is bufferless, emulate a normal Emacs session
- ;; exit and offer to save all buffers. Otherwise, offer to
- ;; save only the buffers belonging to the client.
- (save-some-buffers arg
- (if buffers
- (lambda () (memq (current-buffer) buffers))
- t))
- (server-delete-client proc))))
+ (let ((proc (frame-parameter (selected-frame) 'client)))
+ (cond ((eq proc 'nowait)
+ ;; Nowait frames have no client buffer list.
+ (if (cdr (frame-list))
+ (progn (save-some-buffers arg)
+ (delete-frame))
+ ;; If we're the last frame standing, kill Emacs.
+ (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
+ (lambda () (memq (current-buffer) buffers))
+ t))
+ (server-delete-client proc)))
+ (t (error "Invalid client frame")))))
(define-key ctl-x-map "#" 'server-edit)
;; continue standard unloading
nil)
+(defun server-eval-at (server form)
+ "Eval FORM on Emacs Server SERVER."
+ (let ((auth-file (expand-file-name server server-auth-dir))
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ address port secret process)
+ (unless (file-exists-p auth-file)
+ (error "No such server definition: %s" auth-file))
+ (with-temp-buffer
+ (insert-file-contents auth-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 (open-network-stream "eval-at" (current-buffer)
+ address port))
+ (error "Unable to contact the server"))
+ (set-process-query-on-exit-flag process nil)
+ (process-send-string
+ process
+ (concat "-auth " secret " -eval "
+ (replace-regexp-in-string
+ " " "&_" (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 ".
+ (when (search-forward "\n-print" nil t)
+ (let ((start (point)))
+ (while (search-forward "&_" nil t)
+ (replace-match " " t t))
+ (goto-char start)
+ (read (current-buffer)))))))
+
\f
(provide 'server)
-;; arch-tag: 1f7ecb42-f00a-49f8-906d-61995d84c8d6
;;; server.el ends here