;;; 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 Free Software Foundation, Inc.
+;; 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: William Sommerfeld <wesommer@athena.mit.edu>
;; Maintainer: FSF
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
"Emacs running as a server process."
:group 'external)
+(defcustom server-use-tcp nil
+ "If non-nil, use TCP sockets instead of local sockets."
+ :set #'(lambda (sym val)
+ (unless (featurep 'make-network-process '(:family local))
+ (setq val t)
+ (unless load-in-progress
+ (message "Local sockets unsupported, using TCP sockets")))
+ (when val (random t))
+ (set-default sym val))
+ :group 'server
+ :type 'boolean
+ :version "22.1")
+
+(defcustom server-host nil
+ "The name or IP address to use as host address of the server process.
+If set, the server accepts remote connections; otherwise it is local."
+ :group 'server
+ :type '(choice
+ (string :tag "Name or IP address")
+ (const :tag "Local" nil))
+ :version "22.1")
+(put 'server-host 'risky-local-variable t)
+
+(defcustom server-auth-dir (concat user-emacs-directory "server/")
+ "Directory for server authentication files."
+ :group 'server
+ :type 'directory
+ :version "22.1")
+(put 'server-auth-dir 'risky-local-variable t)
+
+(defcustom server-raise-frame t
+ "If non-nil, raise frame when switching to a buffer."
+ :group 'server
+ :type 'boolean
+ :version "22.1")
+
(defcustom server-visit-hook nil
- "*Hook run when visiting a file for the Emacs server."
+ "Hook run when visiting a file for the Emacs server."
:group 'server
:type 'hook)
(defcustom server-switch-hook nil
- "*Hook run when switching to a buffer for the Emacs server."
+ "Hook run when switching to a buffer for the Emacs server."
:group 'server
:type 'hook)
(defcustom server-done-hook nil
- "*Hook run when done editing a buffer for the Emacs server."
+ "Hook run when done editing a buffer for the Emacs server."
:group 'server
:type 'hook)
(put 'server-buffer-clients 'permanent-local t)
(defcustom server-window nil
- "*Specification of the window to use for selecting Emacs server buffers.
+ "Specification of the window to use for selecting Emacs server buffers.
If nil, use the 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'.
(function :tag "Other function")))
(defcustom server-temp-file-regexp "^/tmp/Re\\|/draft$"
- "*Regexp matching names of temporary files.
+ "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.
+ "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
`server-temp-file-regexp'.
:version "21.1")
(or (assq 'server-buffer-clients minor-mode-alist)
- (setq minor-mode-alist (cons '(server-buffer-clients " Server") minor-mode-alist)))
+ (push '(server-buffer-clients " Server") minor-mode-alist))
(defvar server-existing-buffer nil
"Non-nil means the buffer existed before the server was asked to visit it.
VARS should be a list of strings.
ENV should be in the same format as `process-environment'."
(declare (indent 2))
- (let ((oldvalues (make-symbol "oldvalues"))
+ (let ((old-env (make-symbol "old-env"))
(var (make-symbol "var"))
(value (make-symbol "value"))
(pair (make-symbol "pair")))
- `(let (,oldvalues)
+ `(let ((,old-env process-environment))
(dolist (,var ,vars)
(let ((,value (server-getenv-from ,env ,var)))
- (setq ,oldvalues (cons (cons ,var (getenv ,var)) ,oldvalues))
- (setenv ,var ,value)))
+ (setq process-environment
+ (cons (if (null ,value)
+ ,var
+ (concat ,var "=" ,value))
+ process-environment))))
(unwind-protect
(progn ,@body)
- (dolist (,pair ,oldvalues)
- (setenv (car ,pair) (cdr ,pair)))))))
+ (setq process-environment ,old-env)))))
(defun server-delete-client (client &optional noframe)
"Delete CLIENT, including its buffers, terminals and frames.
"If a *server* buffer exists, write STRING to it for logging purposes.
If CLIENT is non-nil, add a description of it to the logged
message."
- (if (get-buffer "*server*")
- (with-current-buffer "*server*"
- (goto-char (point-max))
- (insert (current-time-string)
- (cond
- ((null client) " ")
- ((listp client) (format " %s: " (car client)))
- (t (format " %s: " client)))
- string)
- (or (bolp) (newline)))))
+ (when (get-buffer "*server*")
+ (with-current-buffer "*server*"
+ (goto-char (point-max))
+ (insert (current-time-string)
+ (cond
+ ((null client) " ")
+ ((listp client) (format " %s: " (car client)))
+ (t (format " %s: " client)))
+ string)
+ (or (bolp) (newline)))))
(defun server-sentinel (proc msg)
"The process sentinel for Emacs server connections."
(when (and (eq (process-status proc) 'open)
(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))))
(server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
(server-delete-client proc))
(setq dir (directory-file-name dir))
(let ((attrs (file-attributes dir)))
(unless attrs
- (letf (((default-file-modes) ?\700)) (make-directory dir))
+ (letf (((default-file-modes) ?\700)) (make-directory dir t))
(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))))
+ (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))))
;;;###autoload
job. To use the server, set up the program `emacsclient' in the
Emacs distribution as your standard \"editor\".
-Prefix arg LEAVE-DEAD means just kill any existing server
-communications subprocess."
+Optional argument LEAVE-DEAD (interactively, a prefix arg) means just
+kill any existing server communications subprocess."
(interactive "P")
(when (or
(not server-clients)
;; It is safe to get the user id now.
(setq server-socket-dir (or server-socket-dir
(format "/tmp/emacs%d" (user-uid))))
- ;; Make sure there is a safe directory in which to place the socket.
- (server-ensure-safe-dir server-socket-dir)
- ;; kill it dead!
- (if server-process
- (condition-case () (delete-process server-process) (error nil)))
+ (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))
;; 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))
- (if server-process
- (server-log (message "Restarting server"))
- (server-log (message "Starting server")))
- (letf (((default-file-modes) ?\700))
- (add-hook 'suspend-tty-functions 'server-handle-suspend-tty)
- (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)
- (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))))))
+ (let* ((server-dir (if server-use-tcp server-auth-dir server-socket-dir))
+ (server-file (expand-file-name server-name server-dir)))
+ ;; 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 'suspend-tty-functions 'server-handle-suspend-tty)
+ (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)
+ (setq server-process
+ (apply #'make-network-process
+ :name server-name
+ :server t
+ :noquery t
+ :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
+ ;; The rest of the args depends on the kind of socket used.
+ (if server-use-tcp
+ (list :family nil
+ :service 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"))
+ (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))))
+ (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))
+ "\n" auth-key)))))))))
;;;###autoload
(define-minor-mode server-mode
;; nothing if there is one (for multiple Emacs sessions)?
(server-start (not server-mode)))
\f
-(defun server-process-filter (proc string)
+(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
The following commands are accepted by the server:
+`-auth AUTH-STRING'
+ Authenticate the client using the secret authentication string
+ AUTH-STRING.
+
`-version CLIENT-VERSION'
Check version numbers between server and client, and signal an
error if there is a mismatch. The server replies with
`-env NAME=VALUE'
An environment variable on the client side.
+`-dir DIRNAME'
+ The current working directory of the client process.
+
`-current-frame'
Forbid the creation of new frames.
`-tty DEVICENAME TYPE'
Open a new tty frame at the client.
-`-resume'
- Resume this tty frame. The client sends this string when it
- gets the SIGCONT signal and it is the foreground process on its
- controlling tty.
-
`-suspend'
Suspend this tty frame. The client sends this string in
response to SIGTSTP and SIGTTOU. The server must cease all I/O
on this tty until it gets a -resume command.
+`-resume'
+ Resume this tty frame. The client sends this string when it
+ gets the SIGCONT signal and it is the foreground process on its
+ controlling tty.
+
`-ignore COMMENT'
Do nothing, but put the comment in the server
log. Useful for debugging.
Suspend this terminal, i.e., stop the client process. Sent
when the user presses C-z."
(server-log (concat "Received " string) proc)
+ ;; First things first: let's check the authentication
+ (unless (process-get proc :authenticated)
+ (if (and (string-match "-auth \\(.*?\\)\n" string)
+ (equal (match-string 1 string) (process-get proc :auth-key)))
+ (progn
+ (setq string (substring string (match-end 0)))
+ (process-put proc :authenticated t)
+ (server-log "Authentication successful" proc))
+ (server-log "Authentication failed" proc)
+ (server-send-string
+ proc (concat "-error " (server-quote-arg "Authentication failed")))
+ (delete-process proc)
+ ;; We return immediately
+ (return-from server-process-filter)))
+ (when (> (recursion-depth) 0)
+ ;; We're inside a minibuffer already, so if the emacs-client is trying
+ ;; to open a frame on a new display, we might end up with an unusable
+ ;; 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.
+ (process-put proc :previous-string string)
+ (run-with-timer 0 nil (lexical-let ((proc proc))
+ (lambda () (server-process-filter proc ""))))
+ (top-level))
+ (condition-case nil
+ ;; If we're running isearch, we must abort it to allow Emacs to
+ ;; display the buffer and switch to it.
+ (mapc #'(lambda (buffer)
+ (with-current-buffer buffer
+ (when (bound-and-true-p isearch-mode)
+ (isearch-cancel))))
+ (buffer-list))
+ ;; Signaled by isearch-cancel
+ (quit (message nil)))
(let ((prev (process-get proc 'previous-string)))
(when prev
(setq string (concat prev string))
display ; Open the frame on this display.
dontkill ; t if the client should not be killed.
env
+ dir
(files nil)
(lineno 1)
(columnno 0))
;; initialization parameters for X frames at
;; the moment.
(modify-frame-parameters frame params)
+ (set-frame-parameter frame 'display-environment-variable
+ (server-getenv-from env "DISPLAY"))
+ (set-frame-parameter frame 'term-environment-variable
+ (server-getenv-from env "TERM"))
(select-frame frame)
(server-client-set client 'frame frame)
(server-client-set client 'terminal (frame-terminal frame))
"BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES"
"NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING"
"NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO"
- "TERMINFO_DIRS" "TERMPATH")
+ "TERMINFO_DIRS" "TERMPATH"
+ ;; rxvt wants these
+ "COLORFGBG" "COLORTERM")
(setq frame (make-frame-on-tty tty type
;; Ignore nowait here; we always need to clean
;; up opened ttys when the client dies.
`((client . ,proc)
(environment . ,env)))))
+
+ (set-frame-parameter frame 'display-environment-variable
+ (server-getenv-from env "DISPLAY"))
+ (set-frame-parameter frame 'term-environment-variable
+ (server-getenv-from env "TERM"))
(select-frame frame)
(server-client-set client 'frame frame)
(server-client-set client 'tty (terminal-name frame))
(setq request (substring request (match-end 0)))
(setq env (cons var env))))
+ ;; -dir DIRNAME: The cwd of the emacsclient process.
+ ((and (equal "-dir" arg) (string-match "\\([^ ]+\\) " request))
+ (setq dir (server-unquote-arg (match-string 1 request)))
+ (setq request (substring request (match-end 0)))
+ (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)))))
;; This looks scary because `fancy-splash-screens'
;; will call `recursive-edit' from a process filter.
;; However, that should be safe to do now.
- (display-splash-screen)
+ (display-splash-screen t)
;; `recursive-edit' will throw an error if Emacs is
;; already doing a recursive edit elsewhere. Catch it
;; here so that we can finish normally.
;; If there is an existing buffer modified or the file is
;; modified, revert it. If there is an existing buffer with
;; deleted file, offer to write it.
- (let* ((filen (car file))
+ (let* ((minibuffer-auto-raise (or server-raise-frame
+ minibuffer-auto-raise))
+ (filen (car file))
(obuf (get-file-buffer filen)))
- (push filen file-name-history)
+ (add-to-history 'file-name-history filen)
(if (and obuf (set-buffer obuf))
(progn
(cond ((file-exists-p filen)
- (if (not (verify-visited-file-modtime obuf))
- (revert-buffer t nil)))
+ (when (not (verify-visited-file-modtime obuf))
+ (revert-buffer t nil)))
(t
- (if (y-or-n-p
- (concat "File no longer exists: " filen
- ", write buffer to file? "))
- (write-file filen))))
+ (when (y-or-n-p
+ (concat "File no longer exists: " filen
+ ", write buffer to file? "))
+ (write-file filen))))
(unless server-buffer-clients
(setq server-existing-buffer t))
(server-goto-line-column file))
(unless buffers
(server-log "Close" client)
(server-delete-client client)))))
- (if (and (bufferp buffer) (buffer-name buffer))
- ;; We may or may not kill this buffer;
- ;; if we do, do not call server-buffer-done recursively
- ;; from kill-buffer-hook.
- (let ((server-kill-buffer-running t))
- (with-current-buffer buffer
- (setq server-buffer-clients nil)
- (run-hooks 'server-done-hook))
- ;; Notice whether server-done-hook killed the buffer.
- (if (null (buffer-name buffer))
+ (when (and (bufferp buffer) (buffer-name buffer))
+ ;; We may or may not kill this buffer;
+ ;; if we do, do not call server-buffer-done recursively
+ ;; from kill-buffer-hook.
+ (let ((server-kill-buffer-running t))
+ (with-current-buffer buffer
+ (setq server-buffer-clients nil)
+ (run-hooks 'server-done-hook))
+ ;; Notice whether server-done-hook killed the buffer.
+ (if (null (buffer-name buffer))
+ (setq killed t)
+ ;; Don't bother killing or burying the buffer
+ ;; when we are called from kill-buffer.
+ (unless for-killing
+ (when (and (not killed)
+ server-kill-new-buffers
+ (with-current-buffer buffer
+ (not server-existing-buffer)))
(setq killed t)
- ;; Don't bother killing or burying the buffer
- ;; when we are called from kill-buffer.
- (unless for-killing
- (when (and (not killed)
- server-kill-new-buffers
- (with-current-buffer buffer
- (not server-existing-buffer)))
- (setq killed t)
- (bury-buffer buffer)
- (kill-buffer buffer))
- (unless killed
- (if (server-temp-file-p buffer)
- (progn
- (kill-buffer buffer)
- (setq killed t))
- (bury-buffer buffer)))))))
+ (bury-buffer buffer)
+ (kill-buffer buffer))
+ (unless killed
+ (if (server-temp-file-p buffer)
+ (progn
+ (kill-buffer buffer)
+ (setq killed t))
+ (bury-buffer buffer)))))))
(list next-buffer killed)))
(defun server-temp-file-p (&optional buffer)
(let ((version-control nil)
(buffer-backed-up nil))
(save-buffer))
- (if (and (buffer-modified-p)
- buffer-file-name
- (y-or-n-p (concat "Save file " buffer-file-name "? ")))
- (save-buffer)))
+ (when (and (buffer-modified-p)
+ buffer-file-name
+ (y-or-n-p (concat "Save file " buffer-file-name "? ")))
+ (save-buffer)))
(server-buffer-done (current-buffer))))
;; Ask before killing a server buffer.
(or (not server-clients)
(let (live-client)
(dolist (client server-clients live-client)
- (if (memq t (mapcar 'buffer-live-p (server-client-get
- client 'buffers)))
- (setq live-client t))))
+ (when (memq t (mapcar 'buffer-live-p (server-client-get
+ client 'buffers)))
+ (setq live-client t))))
(yes-or-no-p "This Emacs session has clients; exit anyway? ")))
(defvar server-kill-buffer-running nil
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
- (not server-process)
- (memq (process-status server-process) '(signal exit)))
- (server-start nil)
- (apply 'server-switch-buffer (server-done))))
+ (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"))))
(defun server-switch-buffer (&optional next-buffer killed-one)
"Switch to another buffer, preferably one that has a client.
(let ((win (get-buffer-window next-buffer 0)))
(if (and win (not server-window))
;; The buffer is already displayed: just reuse the window.
- (let ((frame (window-frame win)))
- (if (eq (frame-visible-p frame) 'icon)
- (raise-frame frame))
- (select-window win)
- (set-buffer next-buffer))
+ (progn
+ (select-window win)
+ (set-buffer next-buffer))
;; Otherwise, let's find an appropriate window.
- (cond ((and (windowp server-window)
- (window-live-p server-window))
+ (cond ((window-live-p server-window)
(select-window server-window))
((framep server-window)
- (if (not (frame-live-p server-window))
- (setq server-window (make-frame)))
+ (unless (frame-live-p server-window)
+ (setq server-window (make-frame)))
(select-window (frame-selected-window server-window))))
- (if (window-minibuffer-p (selected-window))
- (select-window (next-window nil 'nomini 0)))
+ (when (window-minibuffer-p (selected-window))
+ (select-window (next-window nil 'nomini 0)))
;; Move to a non-dedicated window, if we have one.
(when (window-dedicated-p (selected-window))
(select-window
(switch-to-buffer next-buffer)
;; After all the above, we might still have ended up with
;; a minibuffer/dedicated-window (if there's no other).
- (error (pop-to-buffer next-buffer)))))))))
+ (error (pop-to-buffer next-buffer)))))))
+ (when server-raise-frame
+ (select-frame-set-input-focus (window-frame (selected-window))))))
;;;###autoload
(defun server-save-buffers-kill-terminal (proc &optional arg)
(defun server-unload-hook ()
"Unload the server library."
- (server-start t)
+ (server-mode -1)
(remove-hook 'suspend-tty-functions 'server-handle-suspend-tty)
(remove-hook 'delete-frame-functions 'server-handle-delete-frame)
(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 'kill-emacs-hook (lambda () (server-mode -1))) ;Cleanup upon exit.
(add-hook 'server-unload-hook 'server-unload-hook)
\f
(provide 'server)
-;;; arch-tag: 1f7ecb42-f00a-49f8-906d-61995d84c8d6
+;; arch-tag: 1f7ecb42-f00a-49f8-906d-61995d84c8d6
;;; server.el ends here