-;;; 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-2011 Free Software Foundation, Inc.
(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.
(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)))))
(and (process-contact proc :server)
(eq (process-status proc) 'closed)
(ignore-errors
- (delete-file (process-get proc :server-file))))
+ (delete-file (process-get proc :server-file))))
(server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
(server-delete-client proc))
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))))))
(file-name-as-directory dir))
:warning)
(throw :safe t))
- (unless (eql uid (user-uid)) ; is the dir ours?
+ (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))
(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)))
+ (let (delete-by-moving-to-trash)
+ (delete-file server-file)))
(setq server-mode nil) ;; already set by the minor mode code
(display-warning
'server
(when server-use-tcp
(let ((auth-key
(loop
- ;; 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))))
+ ;; 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)
(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)
(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 `((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)))))))
+ '("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.
frame))
-(defun server-create-window-system-frame (display nowait proc parent-id)
+(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))))
+ (environment . ,(process-get proc 'env))
+ ,@parameters))
(display (or display
(frame-parameter nil 'display)
(getenv "DISPLAY")
;; 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:
`-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.
commands
dir
use-current-frame
+ 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)))
-
- ;; -parent-id ID:
- ;; Open X frame within window ID, via XEmbed.
- ((and (equal "-parent-id" arg) command-line-args-left)
- (setq parent-id (pop command-line-args-left))
- (if (zerop (length parent-id)) (setq parent-id 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 (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.
- ((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
(if display (server-select-display display)))
((eq tty-name 'window-system)
(server-create-window-system-frame display nowait proc
- parent-id))
+ 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))
"When done with a buffer, type \\[server-edit]")))))
(when (and frame (null tty-name))
(server-unselect-display frame)))
- (error (server-return-error proc err)))))
+ ((quit error)
+ (when (eq (car err) 'quit)
+ (message "Quit emacsclient request"))
+ (server-return-error proc err)))))
(defun server-return-error (proc err)
(ignore-errors
(add-to-history 'file-name-history filen)
(if (null obuf)
(progn
- (run-hooks 'pre-command-hook)
+ (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)
+ (run-hooks 'pre-command-hook)
(cond ((file-exists-p filen)
(when (not (verify-visited-file-modtime obuf))
(revert-buffer t nil)))
(server-goto-line-column (cdr file))
(run-hooks 'server-visit-hook)
;; hooks may be specific to current buffer:
- (run-hooks 'post-command-hook))
+ (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).
"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.
;; 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)