procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Another server.el overhaul.

Browse source 
lib-src/emacsclient.c (xstrdup): New function.
(quote_argument): Use xmalloc, not malloc.
(main): Send environment variable values.

lisp/server.el (server-clients): Documentation update.
(server-ttys, server-frames): Removed.
(server-client, server-client-get, server-client-set)
(server-clients-with, server-add-client)
(server-delete-client): New functions.
(server-sentinel, server-handle-suspend-tty)
(server-handle-delete-tty, server-handle-delete-frame)
(server-start, server-process-filter, server-visit-files)
(server-buffer-done, server-kill-buffer-query-function)
(server-kill-emacs-query-function, server-switch-buffer): Use them.
(server-log): Handle both kinds of client references.
(server-start): Set up all hooks here.
(server-process-filter): Cleanup.  Store version in client.
Handle -env commands for passing environment variable values.
(server-buffer-done): Don't close clients that were created bufferless.
(server-switch-buffer): Only look at frameless clients.
Don't switch away from current buffer if there is no next-buffer.
(server-unload-hook): Remove frame/tty hooks, too.

lisp/server.el (server-quote-arg, server-unquote-arg)
(server-process-filter, server-kill-buffer-query-function)
(server-kill-emacs-query-function): Doc update.
(server-buffer-done, server-switch-buffer): Use buffer-live-p, not
buffer-name.

git-archimport-id: lorentey@elte.hu--2004/emacs--multi-tty--0--patch-143
This commit is contained in:
Karoly Lorentey 2004-04-18 01:34:11 +00:00
parent 6839f1e289
commit 9002956fd8
3 changed files with 307 additions and 232 deletions
Download patch file Download diff file Expand all files Collapse all files

1
README.multi-tty
View file

@ -174,6 +174,7 @@ Gergely Nagy <algernon at debian dot org>
Mark Plaksin <happy at mcplaksin dot org> Mark Plaksin <happy at mcplaksin dot org>
Francisco Borges <borges at let dot rug dot nl> Francisco Borges <borges at let dot rug dot nl>
Frank Ruell <stoerte at dreamwarrior dot net> Frank Ruell <stoerte at dreamwarrior dot net>
and many others.
Richard Stallman was kind enough to review an earlier version of my Richard Stallman was kind enough to review an earlier version of my
patches. patches.

77
lib-src/emacsclient.c
View file

@ -212,6 +212,35 @@ Report bugs to bug-gnu-emacs@gnu.org.\n", progname);
exit (0); exit (0);
} }
/* Like malloc but get fatal error if memory is exhausted. */
long *
xmalloc (size)
unsigned int size;
{
long *result = (long *) malloc (size);
if (result == NULL)
{
perror ("malloc");
exit (1);
}
return result;
}
/* Like strdup but get a fatal error if memory is exhausted. */
char *
xstrdup (const char *s)
{
char *result = strdup (s);
if (result == NULL)
{
perror ("strdup");
exit (1);
}
return result;
}
/* In STR, insert a & before each &, each space, each newline, and /* In STR, insert a & before each &, each space, each newline, and
any initial -. Change spaces to underscores, too, so that the any initial -. Change spaces to underscores, too, so that the
return value never contains a space. return value never contains a space.
@ -223,7 +252,7 @@ quote_argument (str, stream)
char *str; char *str;
FILE *stream; FILE *stream;
{ {
char *copy = (char *) malloc (strlen (str) * 2 + 1); char *copy = (char *) xmalloc (strlen (str) * 2 + 1);
char *p, *q; char *p, *q;
p = str; p = str;
@ -291,20 +320,6 @@ unquote_argument (str)
return str; return str;
} }
/* Like malloc but get fatal error if memory is exhausted. */
long *
xmalloc (size)
unsigned int size;
{
long *result = (long *) malloc (size);
if (result == NULL)
{
perror ("malloc");
exit (1);
}
return result;
}
/* /*
Try to run a different command, or --if no alternate editor is Try to run a different command, or --if no alternate editor is
@ -610,11 +625,11 @@ main (argc, argv)
/* `stat' failed */ /* `stat' failed */
if (saved_errno == ENOENT) if (saved_errno == ENOENT)
fprintf (stderr, fprintf (stderr,
"%s: Can't find socket; have you started the server?\n\ "%s: can't find socket; have you started the server?\n\
To start the server in Emacs, type \"M-x server-start\".\n", To start the server in Emacs, type \"M-x server-start\".\n",
argv[0]); argv[0]);
else else
fprintf (stderr, "%s: Can't stat %s: %s\n", fprintf (stderr, "%s: can't stat %s: %s\n",
argv[0], server.sun_path, strerror (saved_errno)); argv[0], server.sun_path, strerror (saved_errno));
fail (); fail ();
break; break;
@ -629,7 +644,7 @@ To start the server in Emacs, type \"M-x server-start\".\n",
fail (); fail ();
} }
/* We use the stream OUT to send our command to the server. */ /* We use the stream OUT to send our commands to the server. */
if ((out = fdopen (s, "r+")) == NULL) if ((out = fdopen (s, "r+")) == NULL)
{ {
fprintf (stderr, "%s: ", argv[0]); fprintf (stderr, "%s: ", argv[0]);
@ -637,7 +652,7 @@ To start the server in Emacs, type \"M-x server-start\".\n",
fail (); fail ();
} }
/* We use the stream IN to read the response. /* We use the stream IN to read the responses.
We used to use just one stream for both output and input We used to use just one stream for both output and input
on the socket, but reversing direction works nonportably: on the socket, but reversing direction works nonportably:
on some systems, the output appears as the first input; on some systems, the output appears as the first input;
@ -660,7 +675,7 @@ To start the server in Emacs, type \"M-x server-start\".\n",
#ifdef HAVE_GETCWD #ifdef HAVE_GETCWD
fprintf (stderr, "%s: %s (%s)\n", argv[0], fprintf (stderr, "%s: %s (%s)\n", argv[0],
"Cannot get current working directory", strerror (errno)); "cannot get current working directory", strerror (errno));
#else #else
fprintf (stderr, "%s: %s (%s)\n", argv[0], string, strerror (errno)); fprintf (stderr, "%s: %s (%s)\n", argv[0], string, strerror (errno));
#endif #endif
@ -670,6 +685,28 @@ To start the server in Emacs, type \"M-x server-start\".\n",
/* First of all, send our version number for verification. */ /* First of all, send our version number for verification. */
fprintf (out, "-version %s ", VERSION); fprintf (out, "-version %s ", VERSION);
/* Send over our environment. */
{
extern char **environ;
int i;
for (i = 0; environ[i]; i++)
{
char *name = xstrdup (environ[i]);
char *value = strchr (name, '=');
if (value && strlen (value) > 1)
{
*value++ = 0;
fprintf (out, "-env ");
quote_argument (name, out);
fprintf (out, " ");
quote_argument (value, out);
fprintf (out, " ");
fflush (out);
}
free (name);
}
}
if (nowait) if (nowait)
fprintf (out, "-nowait "); fprintf (out, "-nowait ");

425
lisp/server.el
View file

@ -102,27 +102,8 @@
(defvar server-clients nil (defvar server-clients nil
"List of current server clients. "List of current server clients.
Each element is (CLIENTID BUFFERS...) where CLIENTID is a string Each element is (PROC PROPERTIES...) where PROC is a process object,
that can be given to the server process to identify a client. and PROPERTIES is an association list of client properties.")
When a buffer is marked as \"done\", it is removed from this list.")
(defvar server-ttys nil
"List of current terminal devices used by the server.
Each element is (CLIENTID TTY) where CLIENTID is a string
that can be given to the server process to identify a client.
TTY is the name of the tty device.
When all frames on the device are deleted, the server quits the
connection to the client, and vice versa.")
(defvar server-frames nil
"List of current window-system frames used by the server.
Each element is (CLIENTID FRAME) where CLIENTID is a string
that can be given to the server process to identify a client.
FRAME is the frame that was opened by the client.
When the frame is deleted, the server closes the connection to
the client, and vice versa.")
(defvar server-buffer-clients nil (defvar server-buffer-clients nil
"List of client ids for clients requesting editing of current buffer.") "List of client ids for clients requesting editing of current buffer.")
@ -182,13 +163,97 @@ are done with it in the server.")
(defvar server-socket-dir (defvar server-socket-dir
(format "/tmp/emacs%d" (user-uid))) (format "/tmp/emacs%d" (user-uid)))
(defun server-client (proc)
"Return the Emacs client corresponding to PROC.
PROC must be a process object.
The car of the result is PROC; the cdr is an association list.
See `server-client-get' and `server-client-set'."
(assq proc server-clients))
(defun server-client-get (client property)
"Get the value of PROPERTY in CLIENT.
CLIENT may be a process object, or a client returned by `server-client'.
Return nil if CLIENT has no such property."
(or (listp client) (setq client (server-client client)))
(cdr (assq property (cdr client))))
(defun server-client-set (client property value)
"Set the PROPERTY to VALUE in CLIENT, and return VALUE.
CLIENT may be a process object, or a client returned by `server-client'."
(let (p proc)
(if (listp client)
(setq proc (car client))
(setq proc client
client (server-client client)))
(setq p (assq property client))
(cond
(p (setcdr p value))
(client (setcdr client (cons (cons property value) (cdr client))))
(t (setq server-clients
`((,proc (,property . ,value)) . ,server-clients))))
value))
(defun server-clients-with (property value)
"Return a list of clients with PROPERTY set to VALUE."
(let (result)
(dolist (client server-clients result)
(when (equal value (server-client-get client property))
(setq result (cons (car client) result))))))
(defun server-add-client (proc)
"Create a client for process PROC, if it doesn't already have one.
New clients have no properties."
(unless (server-client proc)
(setq server-clients (cons (cons proc nil)
server-clients))))
(defun server-delete-client (client)
"Delete CLIENT, including its buffers, displays and frames."
;; Force a new lookup of client (prevents infinite recursion).
(setq client (server-client
(if (listp client) (car client) client)))
(let ((proc (car client))
(buffers (server-client-get client 'buffers)))
(when client
(setq server-clients (delq client server-clients))
(dolist (buf buffers)
(with-current-buffer buf
;; Remove PROC from the clients of each buffer.
(setq server-buffer-clients (delq proc server-buffer-clients))
;; Kill the buffer if necessary.
(when (and (null server-buffer-clients)
(or (and server-kill-new-buffers
(not server-existing-buffer))
(server-temp-file-p)))
(kill-buffer (current-buffer)))))
;; Delete the client's tty.
(let ((tty (server-client-get client 'tty)))
(when tty (delete-tty tty)))
;; Delete the client's frames.
(dolist (frame (frame-list))
(if (and (frame-live-p frame)
(equal (car client) (frame-parameter frame 'client)))
(delete-frame frame)))
;; Delete the client's process.
(if (eq (process-status (car client)) 'open)
(delete-process (car client)))
(server-log "Deleted" proc))))
(defun server-log (string &optional client) (defun server-log (string &optional client)
"If a *server* buffer exists, write STRING to it for logging purposes." "If a *server* buffer exists, write STRING to it for logging purposes."
(if (get-buffer "*server*") (if (get-buffer "*server*")
(with-current-buffer "*server*" (with-current-buffer "*server*"
(goto-char (point-max)) (goto-char (point-max))
(insert (current-time-string) (insert (current-time-string)
(if client (format " %s: " client) " ") (cond
((null client) " ")
((listp client) (format " %s: " (car client)))
(t (format " %s: " client)))
string) string)
(or (bolp) (newline))))) (or (bolp) (newline)))))
@ -201,66 +266,28 @@ are done with it in the server.")
(setq result t))))) (setq result t)))))
(defun server-sentinel (proc msg) (defun server-sentinel (proc msg)
(let ((client (assq proc server-clients))) "The process sentinel for Emacs server connections."
;; Remove PROC from the list of clients. (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
(when client (server-delete-client proc))
(setq server-clients (delq client server-clients))
(dolist (buf (cdr client))
(with-current-buffer buf
;; Remove PROC from the clients of each buffer.
(setq server-buffer-clients (delq proc server-buffer-clients))
;; Kill the buffer if necessary.
(when (and (null server-buffer-clients)
(or (and server-kill-new-buffers
(not server-existing-buffer))
(server-temp-file-p)))
(kill-buffer (current-buffer)))))
(let ((tty (assq (car client) server-ttys)))
(when tty
(setq server-ttys (delq tty server-ttys))
(when (server-tty-live-p (cadr tty))
(delete-tty (cadr tty)))))))
(server-log (format "Status changed to %s" (process-status proc)) proc))
(defun server-handle-delete-tty (tty) (defun server-handle-delete-tty (tty)
"Delete the client connection when the emacsclient terminal device is closed." "Delete the client connection when the emacsclient terminal device is closed."
(dolist (entry server-ttys) (dolist (proc (server-clients-with 'tty tty))
(let ((proc (nth 0 entry)) (server-log (format "server-handle-delete-tty, tty %s" tty) proc)
(term (nth 1 entry))) (server-delete-client proc)))
(when (equal term tty)
(let ((client (assq proc server-clients)))
(server-log (format "server-handle-delete-tty, tty %s" tty) (car client))
(setq server-ttys (delq entry server-ttys))
(delete-process (car client))
(when (assq proc server-clients)
;; This seems to be necessary to handle
;; `emacsclient -t -e '(delete-frame)'' correctly.
(setq server-clients (delq client server-clients))))))))
(defun server-handle-suspend-tty (tty)
"Notify the emacsclient process to suspend itself when its tty device is suspended."
(dolist (entry server-ttys)
(let ((proc (nth 0 entry))
(term (nth 1 entry)))
(when (equal term tty)
(let ((process (car (assq proc server-clients))))
(server-log (format "server-handle-suspend-tty, tty %s" tty) process)
(process-send-string process "-suspend \n"))))))
(defun server-handle-delete-frame (frame) (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."
(dolist (entry server-frames) (let ((proc (frame-parameter frame 'client)))
(let ((proc (nth 0 entry)) (when proc
(f (nth 1 entry))) (server-log (format "server-handle-delete-frame, frame %s" frame) proc)
(when (equal frame f) (server-delete-client proc))))
(let ((client (assq proc server-clients)))
(server-log (format "server-handle-delete-frame, frame %s" frame) (car client)) (defun server-handle-suspend-tty (tty)
(setq server-frames (delq entry server-frames)) "Notify the emacsclient process to suspend itself when its tty device is suspended."
(delete-process (car client)) (dolist (proc (server-clients-with 'tty tty))
(when (assq proc server-clients) (server-log (format "server-handle-suspend-tty, tty %s" tty) proc)
;; This seems to be necessary to handle (process-send-string proc "-suspend \n")))
;; `emacsclient -t -e '(delete-frame)'' correctly.
(setq server-clients (delq client server-clients))))))))
(defun server-select-display (display) (defun server-select-display (display)
;; If the current frame is on `display' we're all set. ;; If the current frame is on `display' we're all set.
@ -283,6 +310,7 @@ are done with it in the server.")
;; '((visibility . nil) (minibuffer . only))))))) ;; '((visibility . nil) (minibuffer . only)))))))
(defun server-unquote-arg (arg) (defun server-unquote-arg (arg)
"Remove &-quotation from ARG."
(replace-regexp-in-string (replace-regexp-in-string
"&." (lambda (s) "&." (lambda (s)
(case (aref s 1) (case (aref s 1)
@ -293,7 +321,7 @@ are done with it in the server.")
arg t t)) arg t t))
(defun server-quote-arg (arg) (defun server-quote-arg (arg)
"In NAME, insert a & before each &, each space, each newline, and -. "In ARG, insert a & before each &, each space, each newline, and -.
Change spaces to underscores, too, so that the return value never Change spaces to underscores, too, so that the return value never
contains a space." contains a space."
(replace-regexp-in-string (replace-regexp-in-string
@ -342,20 +370,16 @@ Prefix arg means just kill any existing server communications subprocess."
(error nil)) (error nil))
;; If this Emacs already had a server, clear out associated status. ;; If this Emacs already had a server, clear out associated status.
(while server-clients (while server-clients
(let ((buffer (nth 1 (car server-clients)))) (server-delete-client (car server-clients)))
(server-buffer-done buffer)))
;; Delete any remaining opened frames of the previous server.
(while server-ttys
(let ((tty (cadar server-ttys)))
(setq server-ttys (cdr server-ttys))
(when (server-tty-live-p tty) (delete-tty tty))))
(unless leave-dead (unless leave-dead
(if server-process (if server-process
(server-log (message "Restarting server"))) (server-log (message "Restarting server")))
(letf (((default-file-modes) ?\700)) (letf (((default-file-modes) ?\700))
(add-to-list 'delete-tty-after-functions 'server-handle-delete-tty) (add-hook 'delete-tty-after-functions 'server-handle-delete-tty)
(add-to-list 'suspend-tty-functions 'server-handle-suspend-tty) (add-hook 'suspend-tty-functions 'server-handle-suspend-tty)
(add-to-list 'delete-frame-functions 'server-handle-delete-frame) (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 (setq server-process
(make-network-process (make-network-process
:name "server" :family 'local :server t :noquery t :name "server" :family 'local :server t :noquery t
@ -389,6 +413,7 @@ PROC is the server process. Format of STRING is \"PATH PATH PATH... \\n\"."
(process-put proc 'previous-string nil))) (process-put proc 'previous-string nil)))
(condition-case err (condition-case err
(progn (progn
(server-add-client proc)
;; If the input is multiple lines, ;; If the input is multiple lines,
;; process each line individually. ;; process each line individually.
(while (string-match "\n" string) (while (string-match "\n" string)
@ -396,100 +421,106 @@ PROC is the server process. Format of STRING is \"PATH PATH PATH... \\n\"."
(coding-system (and default-enable-multibyte-characters (coding-system (and default-enable-multibyte-characters
(or file-name-coding-system (or file-name-coding-system
default-file-name-coding-system))) default-file-name-coding-system)))
client nowait newframe display version-checked (client (server-client proc))
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. dontkill ; t if the client should not be killed.
registered ; t if the client is already added to server-clients.
(files nil) (files nil)
(lineno 1) (lineno 1)
(columnno 0)) (columnno 0))
;; Remove this line from STRING. ;; Remove this line from STRING.
(setq string (substring string (match-end 0))) (setq string (substring string (match-end 0)))
(setq client (cons proc nil)) (while (string-match " *[^ ]* " request)
(while (string-match "[^ ]* " request)
(let ((arg (substring request (match-beginning 0) (1- (match-end 0))))) (let ((arg (substring request (match-beginning 0) (1- (match-end 0)))))
(setq request (substring request (match-end 0))) (setq request (substring request (match-end 0)))
(cond (cond
;; Check version numbers. ;; -version CLIENT-VERSION:
((and (equal "-version" arg) (string-match "\\([0-9.]+\\) " request)) ;; Check version numbers, signal an error if there is a mismatch.
((and (equal "-version" arg)
(string-match "\\([0-9.]+\\) " request))
(let* ((client-version (match-string 1 request)) (let* ((client-version (match-string 1 request))
(truncated-emacs-version (substring emacs-version 0 (length client-version)))) (truncated-emacs-version
(substring emacs-version 0 (length client-version))))
(setq request (substring request (match-end 0))) (setq request (substring request (match-end 0)))
(if (equal client-version truncated-emacs-version) (if (equal client-version truncated-emacs-version)
(progn (progn
(process-send-string proc "-good-version \n") (process-send-string proc "-good-version \n")
(setq version-checked t)) (server-client-set client 'version client-version))
(error (concat "Version mismatch: Emacs is " truncated-emacs-version ", emacsclient is " client-version))))) (error (concat "Version mismatch: Emacs is "
truncated-emacs-version
", emacsclient is " client-version)))))
;; -nowait: Emacsclient won't wait for a result.
((equal "-nowait" arg) (setq nowait t)) ((equal "-nowait" arg) (setq nowait t))
;; -display DISPLAY:
;; Open X frames on the given instead of the default.
((and (equal "-display" arg) (string-match "\\([^ ]*\\) " request)) ((and (equal "-display" arg) (string-match "\\([^ ]*\\) " request))
(setq display (match-string 1 request) (setq display (match-string 1 request)
request (substring request (match-end 0)))) request (substring request (match-end 0))))
;; Open a new X frame. ;; -window-system: Open a new X frame.
((equal "-window-system" arg) ((equal "-window-system" arg)
(unless version-checked (unless (server-client-get client 'version)
(error "Protocol error; make sure to use the correct version of emacsclient")) (error "Protocol error; make sure to use the correct version of emacsclient"))
(let ((frame (make-frame-on-display (setq frame (make-frame-on-display
(or display (or display
(frame-parameter nil 'display) (frame-parameter nil 'display)
(getenv "DISPLAY") (getenv "DISPLAY")
(error "Please specify display"))))) (error "Please specify display"))
(push (list proc frame) server-frames) (list (cons 'client proc))))
(select-frame frame) (select-frame frame)
;; This makes sure that `emacsclient -w -e '(delete-frame)'' works right. (server-client-set client 'frame frame)
(push client server-clients) (setq dontkill t))
(setq registered t
newframe t
dontkill t)))
;; Resume a suspended tty frame. ;; -resume: Resume a suspended tty frame.
((equal "-resume" arg) ((equal "-resume" arg)
(let ((tty (cadr (assq (car client) server-ttys)))) (let ((tty (server-client-get client 'tty)))
(setq dontkill t) (setq dontkill t)
(when tty (resume-tty tty)))) (when tty (resume-tty tty))))
;; Suspend the client's frame. (In case we get out of ;; -suspend: Suspend the client's frame. (In case we
;; sync, and a C-z sends a SIGTSTP to emacsclient.) ;; get out of sync, and a C-z sends a SIGTSTP to
;; emacsclient.)
((equal "-suspend" arg) ((equal "-suspend" arg)
(let ((tty (cadr (assq (car client) server-ttys)))) (let ((tty (server-client-get client 'tty)))
(setq dontkill t) (setq dontkill t)
(when tty (suspend-tty tty)))) (when tty (suspend-tty tty))))
;; Noop; useful for debugging emacsclient. ;; -ignore COMMENT: Noop; useful for debugging emacsclient.
;; (The given comment appears in the server log.)
((and (equal "-ignore" arg) (string-match "\\([^ ]*\\) " request)) ((and (equal "-ignore" arg) (string-match "\\([^ ]*\\) " request))
(setq dontkill t (setq dontkill t
request (substring request (match-end 0)))) request (substring request (match-end 0))))
;; Open a new tty frame at the client. ARG is the name of the pseudo tty. ;; -tty DEVICE-NAME TYPE: Open a new tty frame at the client.
((and (equal "-tty" arg) (string-match "\\([^ ]*\\) \\([^ ]*\\) " request)) ((and (equal "-tty" arg) (string-match "\\([^ ]*\\) \\([^ ]*\\) " request))
(let ((tty (server-unquote-arg (match-string 1 request))) (let ((tty (server-unquote-arg (match-string 1 request)))
(type (server-unquote-arg (match-string 2 request)))) (type (server-unquote-arg (match-string 2 request))))
(setq request (substring request (match-end 0))) (setq request (substring request (match-end 0)))
(unless version-checked (unless (server-client-get client 'version)
(error "Protocol error; make sure to use the correct version of emacsclient")) (error "Protocol error; make sure you use the correct version of emacsclient"))
(let ((frame (make-frame-on-tty tty type))) (setq frame (make-frame-on-tty tty type (list (cons 'client proc))))
(push (list (car client) (frame-tty-name frame)) server-ttys)
(process-send-string proc (concat "-emacs-pid " (number-to-string (emacs-pid)) "\n"))
(select-frame frame) (select-frame frame)
;; This makes sure that `emacsclient -t -e '(delete-frame)'' works right. (server-client-set client 'frame frame)
(push client server-clients) (server-client-set client 'tty (frame-tty-name frame))
(setq registered t ;; Reply with our pid.
dontkill t (process-send-string proc (concat "-emacs-pid " (number-to-string (emacs-pid)) "\n"))
newframe t)))) (setq dontkill t)))
;; ARG is a line number option. ;; -position LINE: Go to the given line in the next file.
((and (equal "-position" arg) (string-match "\\(\\+[0-9]+\\) " request)) ((and (equal "-position" arg) (string-match "\\(\\+[0-9]+\\) " request))
(setq request (substring request (match-end 0)) (setq request (substring request (match-end 0))
lineno (string-to-int (substring (match-string 1 request) 1)))) lineno (string-to-int (substring (match-string 1 request) 1))))
;; ARG is line number:column option. ;; -position LINE:COLUMN: Set point to the given position in the next file.
((and (equal "-position" arg) (string-match "\\+\\([0-9]+\\):\\([0-9]+\\) " request)) ((and (equal "-position" arg) (string-match "\\+\\([0-9]+\\):\\([0-9]+\\) " request))
(setq request (substring request (match-end 0)) (setq request (substring request (match-end 0))
lineno (string-to-int (match-string 1 request)) lineno (string-to-int (match-string 1 request))
columnno (string-to-int (match-string 2 request)))) columnno (string-to-int (match-string 2 request))))
;; ARG is a file to load. ;; -file FILENAME: Load the given file.
((and (equal "-file" arg) (string-match "\\([^ ]+\\) " request)) ((and (equal "-file" arg) (string-match "\\([^ ]+\\) " request))
(let ((file (server-unquote-arg (match-string 1 request)))) (let ((file (server-unquote-arg (match-string 1 request))))
(setq request (substring request (match-end 0))) (setq request (substring request (match-end 0)))
@ -500,14 +531,14 @@ PROC is the server process. Format of STRING is \"PATH PATH PATH... \\n\"."
(setq lineno 1 (setq lineno 1
columnno 0)) columnno 0))
;; ARG is a Lisp expression. ;; -eval EXPR: Evaluate a Lisp expression.
((and (equal "-eval" arg) (string-match "\\([^ ]+\\) " request)) ((and (equal "-eval" arg) (string-match "\\([^ ]+\\) " request))
(let ((expr (server-unquote-arg (match-string 1 request)))) (let ((expr (server-unquote-arg (match-string 1 request))))
(setq request (substring request (match-end 0))) (setq request (substring request (match-end 0)))
(if coding-system (if coding-system
(setq expr (decode-coding-string expr coding-system))) (setq expr (decode-coding-string expr coding-system)))
(let ((v (eval (car (read-from-string expr))))) (let ((v (eval (car (read-from-string expr)))))
(when (and (not newframe) v) (when (and (not frame) v)
(with-temp-buffer (with-temp-buffer
(let ((standard-output (current-buffer))) (let ((standard-output (current-buffer)))
(pp v) (pp v)
@ -520,6 +551,19 @@ PROC is the server process. Format of STRING is \"PATH PATH PATH... \\n\"."
(setq lineno 1 (setq lineno 1
columnno 0))) columnno 0)))
;; -env NAME VALUE: An environment variable.
((and (equal "-env" arg) (string-match "\\([^ ]+\\) \\([^ ]+\\) " request))
(let ((name (server-unquote-arg (match-string 1 request)))
(value (server-unquote-arg (match-string 2 request))))
(when coding-system
(setq name (decode-coding-string name coding-system))
(setq value (decode-coding-string value coding-system)))
(setq request (substring request (match-end 0)))
(server-client-set
client 'environment
(cons (cons name value)
(server-client-get client 'environment)))))
;; Unknown command. ;; Unknown command.
(t (error "Unknown command: %s" arg))))) (t (error "Unknown command: %s" arg)))))
@ -528,34 +572,33 @@ PROC is the server process. Format of STRING is \"PATH PATH PATH... \\n\"."
(server-visit-files files client nowait) (server-visit-files files client nowait)
(run-hooks 'post-command-hook)) (run-hooks 'post-command-hook))
;; CLIENT is now a list (CLIENTNUM BUFFERS...)
;; Delete the client if necessary. ;; Delete the client if necessary.
(cond (cond
;; Client requested nowait; return immediately.
(nowait (nowait
(delete-process proc) ;; Client requested nowait; return immediately.
(server-log "Close nowait client" proc)) (server-log "Close nowait client" proc)
(server-delete-client proc))
((and (not dontkill)
(null (server-client-get client 'buffers)))
;; This client is empty; get rid of it immediately. ;; This client is empty; get rid of it immediately.
((and (not dontkill) (null (cdr client))) (server-log "Close empty client" proc)
(delete-process proc) (server-delete-client proc))
(server-log "Close empty client" proc)) (t
((not registered) (let ((buffers (server-client-get client 'buffers)))
(push client server-clients))) (when buffers
;; We visited some buffer for this client. ;; We visited some buffer for this client.
(cond (cond
((or isearch-mode (minibufferp)) ((or isearch-mode (minibufferp))
nil) nil)
((and newframe (null (cdr client))) ((and frame (null buffers))
(message (substitute-command-keys (message (substitute-command-keys
"When done with this frame, type \\[delete-frame]"))) "When done with this frame, type \\[delete-frame]")))
((not (null (cdr client))) ((not (null buffers))
(server-switch-buffer (nth 1 client)) (server-switch-buffer (car buffers))
(run-hooks 'server-switch-hook) (run-hooks 'server-switch-hook)
(unless nowait (unless nowait
(message (substitute-command-keys (message (substitute-command-keys
"When done with a buffer, type \\[server-edit]"))))))) "When done with a buffer, type \\[server-edit]")))))))))))
;; Save for later any partial line that remains. ;; Save for later any partial line that remains.
(when (> (length string) 0) (when (> (length string) 0)
@ -599,8 +642,7 @@ so don't mark these buffers specially, just visit them normally."
(revert-buffer t nil))) (revert-buffer t nil)))
(t (t
(if (y-or-n-p (if (y-or-n-p
(concat "File no longer exists: " (concat "File no longer exists: " filen
filen
", write buffer to file? ")) ", write buffer to file? "))
(write-file filen)))) (write-file filen))))
(setq server-existing-buffer t) (setq server-existing-buffer t)
@ -613,7 +655,9 @@ so don't mark these buffers specially, just visit them normally."
(add-hook 'kill-buffer-hook 'server-kill-buffer nil t) (add-hook 'kill-buffer-hook 'server-kill-buffer nil t)
(push (car client) server-buffer-clients)) (push (car client) server-buffer-clients))
(push (current-buffer) client-record))) (push (current-buffer) client-record)))
(nconc client client-record))) (server-client-set
client 'buffers
(nconc (server-client-get client 'buffers) client-record))))
(defun server-buffer-done (buffer &optional for-killing) (defun server-buffer-done (buffer &optional for-killing)
"Mark BUFFER as \"done\" for its client(s). "Mark BUFFER as \"done\" for its client(s).
@ -623,35 +667,24 @@ or nil. KILLED is t if we killed BUFFER (typically, because it was visiting
a temp file). a temp file).
FOR-KILLING if non-nil indicates that we are called from `kill-buffer'." FOR-KILLING if non-nil indicates that we are called from `kill-buffer'."
(let ((next-buffer nil) (let ((next-buffer nil)
(killed nil) (killed nil))
(old-clients server-clients)) (dolist (client server-clients)
(while old-clients (let ((buffers (server-client-get client 'buffers)))
(let ((client (car old-clients)))
(or next-buffer (or next-buffer
(setq next-buffer (nth 1 (memq buffer client)))) (setq next-buffer (nth 1 (memq buffer buffers))))
(delq buffer client) (when buffers ; Ignore bufferless clients.
(setq buffers (delq buffer buffers))
;; Delete all dead buffers from CLIENT. ;; Delete all dead buffers from CLIENT.
(let ((tail client)) (dolist (b buffers)
(while tail (and (bufferp b)
(and (bufferp (car tail)) (not (buffer-live-p b))
(null (buffer-name (car tail))) (setq buffers (delq b buffers))))
(delq (car tail) client)) (server-client-set client 'buffers buffers)
(setq tail (cdr tail))))
;; If client now has no pending buffers, ;; If client now has no pending buffers,
;; tell it that it is done, and forget it entirely. ;; tell it that it is done, and forget it entirely.
(unless (cdr client) (unless buffers
(let ((tty (cadr (assq (car client) server-ttys))) (server-log "Close" client)
(frame (cadr (assq (car client) server-frames)))) (server-delete-client client)))))
(cond
;; Be careful, if we delete the process before the
;; tty, then the terminal modes will not be restored
;; correctly.
(tty (delete-tty tty))
(frame (delete-frame frame))
(t (delete-process (car client))
(server-log "Close" (car client))
(setq server-clients (delq client server-clients)))))))
(setq old-clients (cdr old-clients)))
(if (and (bufferp buffer) (buffer-name buffer)) (if (and (bufferp buffer) (buffer-name buffer))
;; We may or may not kill this buffer; ;; We may or may not kill this buffer;
;; if we do, do not call server-buffer-done recursively ;; if we do, do not call server-buffer-done recursively
@ -716,30 +749,25 @@ specifically for the clients and did not exist before their request for it."
;; but I think that is dangerous--the client would proceed ;; but I think that is dangerous--the client would proceed
;; using whatever is on disk in that file. -- rms. ;; using whatever is on disk in that file. -- rms.
(defun server-kill-buffer-query-function () (defun server-kill-buffer-query-function ()
"Ask before killing a server buffer."
(or (not server-buffer-clients) (or (not server-buffer-clients)
(let ((res t)) (let ((res t))
(dolist (proc server-buffer-clients res) (dolist (proc server-buffer-clients res)
(setq proc (assq proc server-clients)) (let ((client (server-client proc)))
(when (and proc (eq (process-status (car proc)) 'open)) (when (and client (eq (process-status proc) 'open))
(setq res nil)))) (setq res nil)))))
(yes-or-no-p (format "Buffer `%s' still has clients; kill it? " (yes-or-no-p (format "Buffer `%s' still has clients; kill it? "
(buffer-name (current-buffer)))))) (buffer-name (current-buffer))))))
(add-hook 'kill-buffer-query-functions
'server-kill-buffer-query-function)
(defun server-kill-emacs-query-function () (defun server-kill-emacs-query-function ()
(let (live-client "Ask before exiting Emacs it has are live clients."
(tail server-clients)) (or (not server-clients)
;; See if any clients have any buffers that are still alive. (let (live-client)
(while tail (dolist (client server-clients live-client)
(if (memq t (mapcar 'stringp (mapcar 'buffer-name (cdr (car tail))))) (if (memq t (mapcar 'buffer-live-p (server-client-get
(setq live-client t)) client 'buffers)))
(setq tail (cdr tail))) (setq live-client t))))
(or (not live-client) (yes-or-no-p "This Emacs session has clients; exit anyway? ")))
(yes-or-no-p "Server buffers still have clients; exit anyway? "))))
(add-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function)
(defvar server-kill-buffer-running nil (defvar server-kill-buffer-running nil
"Non-nil while `server-kill-buffer' or `server-buffer-done' is running.") "Non-nil while `server-kill-buffer' or `server-buffer-done' is running.")
@ -782,13 +810,19 @@ Arg NEXT-BUFFER is a suggestion; if it is a live buffer, use it."
;; This means we should avoid the final "switch to some other buffer" ;; This means we should avoid the final "switch to some other buffer"
;; since we've already effectively done that. ;; since we've already effectively done that.
(if (null next-buffer) (if (null next-buffer)
(if server-clients (progn
(let ((buffer (nth 1 (car server-clients)))) (let ((rest server-clients))
(and buffer (server-switch-buffer buffer killed-one))) (while (and rest (not next-buffer))
(unless (or killed-one (window-dedicated-p (selected-window))) (let ((client (car rest)))
(switch-to-buffer (other-buffer)) ;; Only look at frameless clients.
(when (not (server-client-get client 'frame))
(setq next-buffer (car (server-client-get client 'buffers))))
(setq rest (cdr rest)))))
(and next-buffer (server-switch-buffer next-buffer killed-one))
(unless (or next-buffer killed-one (window-dedicated-p (selected-window)))
;; (switch-to-buffer (other-buffer))
(message "No server buffers remain to edit"))) (message "No server buffers remain to edit")))
(if (not (buffer-name next-buffer)) (if (not (buffer-live-p next-buffer))
;; If NEXT-BUFFER is a dead buffer, remove the server records for it ;; If NEXT-BUFFER is a dead buffer, remove the server records for it
;; and try the next surviving server buffer. ;; and try the next surviving server buffer.
(apply 'server-switch-buffer (server-buffer-done next-buffer)) (apply 'server-switch-buffer (server-buffer-done next-buffer))
@ -832,6 +866,9 @@ Arg NEXT-BUFFER is a suggestion; if it is a live buffer, use it."
(defun server-unload-hook () (defun server-unload-hook ()
(server-start t) (server-start t)
(remove-hook 'delete-tty-after-functions 'server-handle-delete-tty)
(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-buffer-query-functions 'server-kill-buffer-query-function)
(remove-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function) (remove-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function)
(remove-hook 'kill-buffer-hook 'server-kill-buffer)) (remove-hook 'kill-buffer-hook 'server-kill-buffer))