;;; server.el --- Lisp code for GNU Emacs running as server process
;; Copyright (C) 1986, 1987, 1992, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Free Software Foundation, Inc.
;; Author: William Sommerfeld <wesommer@athena.mit.edu>
;; Maintainer: FSF
(put 'server-host '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")
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
(and (featurep 'make-network-process '(:family local))
(format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid)))
`(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))))
- 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
Optional argument LEAVE-DEAD (interactively, a prefix arg) means just
kill any existing server communications subprocess.
-If a server is already running, the server is not started.
+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 (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
;; Remove any leftover socket or authentication file
(ignore-errors (delete-file server-file))
(setq server-mode nil) ;; already set by the minor mode code
- (display-warning 'server
- (format "Emacs server named %S already running" server-name)
- :warning)
+ (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
(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
+ (list :family 'ipv4 ;; We're not ready for IPv6 yet
:service t
- :host (or server-host 'local)
+ :host (or server-host "127.0.0.1") ;; See bug#6781
:plist '(:authenticated nil))
(list :family 'local
:service server-file
" " (int-to-string (emacs-pid))
"\n" auth-key)))))))))
+(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.
(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
- (system-process-attributes
+ (process-attributes
(string-to-number (match-string 1))))
t)
:other))
(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)
- (unless tty (error "Invalid terminal device"))
- (unless type (error "Invalid terminal type"))
(let ((frame
(server-with-environment (process-get proc 'env)
'("LANG" "LC_CTYPE" "LC_ALL"
"TERMINFO_DIRS" "TERMPATH"
;; rxvt wants these
"COLORFGBG" "COLORTERM")
- (let ((ws (if (eq window-system 'pc) 'pc nil))
- ;; Ignore nowait here; we always need to clean up
- ;; opened ttys when the client dies.
- (parameters `((client . ,proc)
- ;; This is left over from an earlier
- ;; attempt at causing a 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)))))
- (make-frame `((window-system . ,ws)
+ (make-frame `((window-system . nil)
(tty . ,tty)
- (tty-type . ,type) . ,parameters))))))
+ (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.
(set-frame-parameter frame 'display
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.
;; 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.
(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))
+ (setq file (expand-file-name file dir))
(push (cons file filepos) files)
(server-log (format "New file: %s %s"
file (or filepos "")) proc))
;; 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)
(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
+ (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 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)))
+ (error (server-return-error proc err)))))
(defun server-return-error (proc err)
(ignore-errors
"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))))))
(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)))))))
(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.
-
+ "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)