;;; 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 Free Software Foundation, Inc.
+;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: William Sommerfeld <wesommer@athena.mit.edu>
;; Maintainer: FSF
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(defvar server-name "server")
-(defvar server-socket-dir nil
- "The directory in which to place the server socket.
-Initialized by `server-start'.")
+(defvar server-socket-dir (format "/tmp/emacs%d" (user-uid))
+ "The directory in which to place the server socket.")
(defun server-clients-with (property value)
"Return a list of clients with PROPERTY set to VALUE."
"Delete PROC, including its buffers, terminals and frames.
If NOFRAME is non-nil, let the frames live. (To be used from
`delete-frame-functions'.)"
- (server-log (concat "server-delete-client" (if noframe " noframe"))
- proc)
+ (server-log (concat "server-delete-client" (if noframe " noframe")) proc)
;; Force a new lookup of client (prevents infinite recursion).
(when (memq proc server-clients)
(let ((buffers (process-get proc 'buffers)))
(server-log "Deleted" proc))))
+(defvar server-log-time-function 'current-time-string
+ "Function to generate timestamps for `server-buffer'.")
+
+(defconst server-buffer " *server*"
+ "Buffer used internally by Emacs's server.
+One use is to log the I/O for debugging purposes (see `server-log'),
+the other is to provide a current buffer in which the process filter can
+safely let-bind buffer-local variables like `default-directory'.")
+
+(defvar server-log nil
+ "If non-nil, log the server's inputs and outputs in the `server-buffer'.")
+
(defun server-log (string &optional client)
- "If a *server* buffer exists, write STRING to it for logging purposes.
+ "If `server-log' is non-nil, log STRING to `server-buffer'.
If CLIENT is non-nil, add a description of it to the logged message."
- (when (get-buffer "*server*")
- (with-current-buffer "*server*"
+ (when server-log
+ (with-current-buffer (get-buffer-create server-buffer)
(goto-char (point-max))
- (insert (current-time-string)
+ (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)))))
display
;; Make it display (and remember) some dummy buffer, so
;; we can detect later if the frame is in use or not.
- `((server-dummmy-buffer . ,buffer)
+ `((server-dummy-buffer . ,buffer)
;; This frame may be deleted later (see
;; server-unselect-display) so we want it to be as
;; unobtrusive as possible.
(not server-clients)
(yes-or-no-p
"The current server still has clients; delete them? "))
- ;; It is safe to get the user id now.
- (setq server-socket-dir (or server-socket-dir
- (format "/tmp/emacs%d" (user-uid))))
(when server-process
;; kill it dead!
(ignore-errors (delete-process server-process)))
(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.
(setq server-process
(apply #'make-network-process
:name server-name
: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.
+ ;; to file-name-coding-system. Also don't get
+ ;; confused by CRs since we don't quote them.
+ :coding 'raw-text-unix
+ ;; The other args depend on the kind of socket used.
(if server-use-tcp
(list :family nil
:service t
(error "Please specify display"))
params)))
(server-log (format "%s created" frame) proc)
- ;; XXX We need to ensure the parameters are really set because Emacs
- ;; forgets unhandled initialization parameters for X frames at
- ;; the moment.
- (modify-frame-parameters frame params)
(select-frame frame)
(process-put proc 'frame frame)
(process-put proc 'terminal (frame-terminal frame))
(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)
+ (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)))
(tty-name nil) ;nil, `window-system', or the tty name.
tty-type ;string.
(files nil)
- (lineno 1)
- (columnno 0))
+ (filepos nil)
+ command-line-args-left
+ arg)
;; Remove this line from STRING.
(setq string (substring string (match-end 0)))
- (while (string-match " *[^ ]* " request)
- (let ((arg (substring request (match-beginning 0)
- (1- (match-end 0)))))
- (setq request (substring request (match-end 0)))
+ (setq command-line-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) (string-match "[^ ]+ " request))
- (setq request (substring request (match-end 0))))
+ ((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))
;; -display DISPLAY:
;; Open X frames on the given display instead of the default.
- ((and (equal "-display" arg)
- (string-match "\\([^ ]*\\) " request))
- (setq display (match-string 1 request))
- (setq request (substring request (match-end 0))))
+ ((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)
;; -ignore COMMENT: Noop; useful for debugging emacsclient.
;; (The given comment appears in the server log.)
- ((and (equal "-ignore" arg) (string-match "[^ ]* " request))
- (setq dontkill t
- request (substring request (match-end 0))))
+ ((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)
- (string-match "\\([^ ]*\\) \\([^ ]*\\) " request))
- (setq tty-name (match-string 1 request))
- (setq tty-type (match-string 2 request))
- (setq dontkill t)
- (setq request (substring request (match-end 0))))
+ (cdr command-line-args-left))
+ (setq tty-name (pop command-line-args-left)
+ tty-type (pop command-line-args-left)
+ dontkill t))
;; -position LINE[:COLUMN]: Set point to the given
;; position in the next file.
((and (equal "-position" arg)
- (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)? "
- request))
- (setq lineno (string-to-number (match-string 1 request))
- columnno (if (null (match-end 2)) 0
- (string-to-number (match-string 2 request)))
- request (substring request (match-end 0))))
+ 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)
- (string-match "\\([^ ]+\\) " request))
- (let ((file (server-unquote-arg (match-string 1 request))))
- (setq request (substring request (match-end 0)))
+ 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 (list file lineno columnno) files)
- (server-log (format "New file: %s (%d:%d)"
- file lineno columnno) proc))
- (setq lineno 1
- columnno 0))
+ (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)
- (string-match "\\([^ ]+\\) " request))
- (lexical-let ((expr (server-unquote-arg
- (match-string 1 request))))
- (setq request (substring request (match-end 0)))
+ command-line-args-left)
+ (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 lineno 1
- columnno 0)))
+ (setq filepos nil)))
;; -env NAME=VALUE: An environment variable.
- ((and (equal "-env" arg) (string-match "\\([^ ]+\\) " request))
- (let ((var (server-unquote-arg (match-string 1 request))))
+ ((and (equal "-env" arg) command-line-args-left)
+ (let ((var (pop command-line-args-left)))
;; XXX Variables should be encoded as in getenv/setenv.
- (setq request (substring request (match-end 0)))
(process-put proc 'env
(cons var (process-get proc '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)))
+ ((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)))))
+ (t (error "Unknown command: %s" arg))))
(setq frame
(case tty-name
(server-create-window-system-frame display nowait proc))
(t (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)
- (tty-name tty-name))
- (lambda ()
- (server-execute proc files nowait commands
- dontkill frame tty-name))))
+ (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))))))
(when (or frame files)
(server-goto-toplevel proc))
(server-log (error-message-string err) proc)
(delete-process proc)))
-(defun server-goto-line-column (file-line-col)
- "Move point to the position indicated in FILE-LINE-COL.
-FILE-LINE-COL should be a three-element list as described in
-`server-visit-files'."
- (goto-line (nth 1 file-line-col))
- (let ((column-number (nth 2 file-line-col)))
- (when (> column-number 0)
- (move-to-column (1- column-number)))))
+(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))
+ (let ((column-number (cdr line-col)))
+ (when (> column-number 0)
+ (move-to-column (1- column-number))))))
(defun server-visit-files (files proc &optional nowait)
"Find FILES and return a list of buffers created.
-FILES is an alist whose elements are (FILENAME LINENUMBER COLUMNNUMBER).
+FILES is an alist whose elements are (FILENAME . FILEPOS)
+where FILEPOS can be nil or a pair (LINENUMBER . COLUMNNUMBER).
PROC is the client that requested this operation.
NOWAIT non-nil means this client is not waiting for the results,
so don't mark these buffers specially, just visit them normally."
(filen (car file))
(obuf (get-file-buffer filen)))
(add-to-history 'file-name-history filen)
- (if (and obuf (set-buffer obuf))
- (progn
- (cond ((file-exists-p filen)
- (when (not (verify-visited-file-modtime obuf))
- (revert-buffer t nil)))
- (t
- (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))
- (set-buffer (find-file-noselect filen))
- (server-goto-line-column file)
- (run-hooks 'server-visit-hook)))
+ (if (null obuf)
+ (set-buffer (find-file-noselect filen))
+ (set-buffer obuf)
+ (cond ((file-exists-p filen)
+ (when (not (verify-visited-file-modtime obuf))
+ (revert-buffer t nil)))
+ (t
+ (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 (cdr file))
+ (run-hooks 'server-visit-hook))
(unless nowait
;; When the buffer is killed, inform the clients.
(add-hook 'kill-buffer-hook 'server-kill-buffer nil t)
(let ((rest server-clients))
(while (and rest (not next-buffer))
(let ((proc (car rest)))
- ;; Only look at frameless clients.
- (when (not (process-get proc 'frame))
+ ;; Only look at frameless clients, or those in the selected
+ ;; frame.
+ (when (or (not (process-get proc 'frame))
+ (eq (process-get proc 'frame) (selected-frame)))
(setq next-buffer (car (process-get proc 'buffers))))
(setq rest (cdr rest)))))
(and next-buffer (server-switch-buffer next-buffer killed-one))
;;;###autoload
(defun server-save-buffers-kill-terminal (proc &optional 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.
If emacsclient was started with a list of filenames to edit, then
only these files will be asked to be saved."
- (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)))
+ ;; 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))))
(define-key ctl-x-map "#" 'server-edit)
-(defun server-unload-hook ()
+(defun server-unload-function ()
"Unload the server library."
(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)
+ (substitute-key-definition 'server-edit nil ctl-x-map)
+ (save-current-buffer
+ (dolist (buffer (buffer-list))
+ (set-buffer buffer)
+ (remove-hook 'kill-buffer-hook 'server-kill-buffer t)))
+ ;; continue standard unloading
+ nil)
+
\f
(provide 'server)