mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-29 07:58:28 +00:00
Another server.el overhaul.
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
parent
6839f1e289
commit
9002956fd8
@ -174,6 +174,7 @@ Gergely Nagy <algernon at debian dot org>
|
||||
Mark Plaksin <happy at mcplaksin dot org>
|
||||
Francisco Borges <borges at let dot rug dot nl>
|
||||
Frank Ruell <stoerte at dreamwarrior dot net>
|
||||
and many others.
|
||||
|
||||
Richard Stallman was kind enough to review an earlier version of my
|
||||
patches.
|
||||
|
||||
@ -212,6 +212,35 @@ Report bugs to bug-gnu-emacs@gnu.org.\n", progname);
|
||||
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
|
||||
any initial -. Change spaces to underscores, too, so that the
|
||||
return value never contains a space.
|
||||
@ -223,7 +252,7 @@ quote_argument (str, stream)
|
||||
char *str;
|
||||
FILE *stream;
|
||||
{
|
||||
char *copy = (char *) malloc (strlen (str) * 2 + 1);
|
||||
char *copy = (char *) xmalloc (strlen (str) * 2 + 1);
|
||||
char *p, *q;
|
||||
|
||||
p = str;
|
||||
@ -291,20 +320,6 @@ unquote_argument (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
|
||||
@ -610,11 +625,11 @@ main (argc, argv)
|
||||
/* `stat' failed */
|
||||
if (saved_errno == ENOENT)
|
||||
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",
|
||||
argv[0]);
|
||||
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));
|
||||
fail ();
|
||||
break;
|
||||
@ -629,7 +644,7 @@ To start the server in Emacs, type \"M-x server-start\".\n",
|
||||
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)
|
||||
{
|
||||
fprintf (stderr, "%s: ", argv[0]);
|
||||
@ -637,7 +652,7 @@ To start the server in Emacs, type \"M-x server-start\".\n",
|
||||
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
|
||||
on the socket, but reversing direction works nonportably:
|
||||
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
|
||||
fprintf (stderr, "%s: %s (%s)\n", argv[0],
|
||||
"Cannot get current working directory", strerror (errno));
|
||||
"cannot get current working directory", strerror (errno));
|
||||
#else
|
||||
fprintf (stderr, "%s: %s (%s)\n", argv[0], string, strerror (errno));
|
||||
#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. */
|
||||
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)
|
||||
fprintf (out, "-nowait ");
|
||||
|
||||
|
||||
461
lisp/server.el
461
lisp/server.el
@ -102,27 +102,8 @@
|
||||
|
||||
(defvar server-clients nil
|
||||
"List of current server clients.
|
||||
Each element is (CLIENTID BUFFERS...) where CLIENTID is a string
|
||||
that can be given to the server process to identify a client.
|
||||
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.")
|
||||
Each element is (PROC PROPERTIES...) where PROC is a process object,
|
||||
and PROPERTIES is an association list of client properties.")
|
||||
|
||||
(defvar server-buffer-clients nil
|
||||
"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
|
||||
(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)
|
||||
"If a *server* buffer exists, write STRING to it for logging purposes."
|
||||
(if (get-buffer "*server*")
|
||||
(with-current-buffer "*server*"
|
||||
(goto-char (point-max))
|
||||
(insert (current-time-string)
|
||||
(if client (format " %s: " client) " ")
|
||||
(cond
|
||||
((null client) " ")
|
||||
((listp client) (format " %s: " (car client)))
|
||||
(t (format " %s: " client)))
|
||||
string)
|
||||
(or (bolp) (newline)))))
|
||||
|
||||
@ -201,66 +266,28 @@ are done with it in the server.")
|
||||
(setq result t)))))
|
||||
|
||||
(defun server-sentinel (proc msg)
|
||||
(let ((client (assq proc server-clients)))
|
||||
;; Remove PROC from the list of clients.
|
||||
(when client
|
||||
(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))
|
||||
"The process sentinel for Emacs server connections."
|
||||
(server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
|
||||
(server-delete-client proc))
|
||||
|
||||
(defun server-handle-delete-tty (tty)
|
||||
"Delete the client connection when the emacsclient terminal device is closed."
|
||||
(dolist (entry server-ttys)
|
||||
(let ((proc (nth 0 entry))
|
||||
(term (nth 1 entry)))
|
||||
(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"))))))
|
||||
(dolist (proc (server-clients-with 'tty tty))
|
||||
(server-log (format "server-handle-delete-tty, tty %s" tty) proc)
|
||||
(server-delete-client proc)))
|
||||
|
||||
(defun server-handle-delete-frame (frame)
|
||||
"Delete the client connection when the emacsclient frame is deleted."
|
||||
(dolist (entry server-frames)
|
||||
(let ((proc (nth 0 entry))
|
||||
(f (nth 1 entry)))
|
||||
(when (equal frame f)
|
||||
(let ((client (assq proc server-clients)))
|
||||
(server-log (format "server-handle-delete-frame, frame %s" frame) (car client))
|
||||
(setq server-frames (delq entry server-frames))
|
||||
(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))))))))
|
||||
(let ((proc (frame-parameter frame 'client)))
|
||||
(when proc
|
||||
(server-log (format "server-handle-delete-frame, frame %s" frame) proc)
|
||||
(server-delete-client proc))))
|
||||
|
||||
(defun server-handle-suspend-tty (tty)
|
||||
"Notify the emacsclient process to suspend itself when its tty device is suspended."
|
||||
(dolist (proc (server-clients-with 'tty tty))
|
||||
(server-log (format "server-handle-suspend-tty, tty %s" tty) proc)
|
||||
(process-send-string proc "-suspend \n")))
|
||||
|
||||
(defun server-select-display (display)
|
||||
;; 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)))))))
|
||||
|
||||
(defun server-unquote-arg (arg)
|
||||
"Remove &-quotation from ARG."
|
||||
(replace-regexp-in-string
|
||||
"&." (lambda (s)
|
||||
(case (aref s 1)
|
||||
@ -293,7 +321,7 @@ are done with it in the server.")
|
||||
arg t t))
|
||||
|
||||
(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
|
||||
contains a space."
|
||||
(replace-regexp-in-string
|
||||
@ -342,20 +370,16 @@ Prefix arg means just kill any existing server communications subprocess."
|
||||
(error nil))
|
||||
;; If this Emacs already had a server, clear out associated status.
|
||||
(while server-clients
|
||||
(let ((buffer (nth 1 (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))))
|
||||
(server-delete-client (car server-clients)))
|
||||
(unless leave-dead
|
||||
(if server-process
|
||||
(server-log (message "Restarting server")))
|
||||
(letf (((default-file-modes) ?\700))
|
||||
(add-to-list 'delete-tty-after-functions 'server-handle-delete-tty)
|
||||
(add-to-list 'suspend-tty-functions 'server-handle-suspend-tty)
|
||||
(add-to-list 'delete-frame-functions 'server-handle-delete-frame)
|
||||
(add-hook 'delete-tty-after-functions 'server-handle-delete-tty)
|
||||
(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
|
||||
@ -389,6 +413,7 @@ PROC is the server process. Format of STRING is \"PATH PATH PATH... \\n\"."
|
||||
(process-put proc 'previous-string nil)))
|
||||
(condition-case err
|
||||
(progn
|
||||
(server-add-client proc)
|
||||
;; If the input is multiple lines,
|
||||
;; process each line individually.
|
||||
(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
|
||||
(or 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.
|
||||
registered ; t if the client is already added to server-clients.
|
||||
(files nil)
|
||||
(lineno 1)
|
||||
(columnno 0))
|
||||
;; Remove this line from STRING.
|
||||
(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)))))
|
||||
(setq request (substring request (match-end 0)))
|
||||
(cond
|
||||
;; Check version numbers.
|
||||
((and (equal "-version" arg) (string-match "\\([0-9.]+\\) " request))
|
||||
;; -version CLIENT-VERSION:
|
||||
;; 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))
|
||||
(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)))
|
||||
(if (equal client-version truncated-emacs-version)
|
||||
(progn
|
||||
(process-send-string proc "-good-version \n")
|
||||
(setq version-checked t))
|
||||
(error (concat "Version mismatch: Emacs is " truncated-emacs-version ", emacsclient is " client-version)))))
|
||||
(server-client-set client 'version 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))
|
||||
|
||||
;; -display DISPLAY:
|
||||
;; Open X frames on the given instead of the default.
|
||||
((and (equal "-display" arg) (string-match "\\([^ ]*\\) " request))
|
||||
(setq display (match-string 1 request)
|
||||
request (substring request (match-end 0))))
|
||||
|
||||
;; Open a new X frame.
|
||||
;; -window-system: Open a new X frame.
|
||||
((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"))
|
||||
(let ((frame (make-frame-on-display
|
||||
(or display
|
||||
(frame-parameter nil 'display)
|
||||
(getenv "DISPLAY")
|
||||
(error "Please specify display")))))
|
||||
(push (list proc frame) server-frames)
|
||||
(select-frame frame)
|
||||
;; This makes sure that `emacsclient -w -e '(delete-frame)'' works right.
|
||||
(push client server-clients)
|
||||
(setq registered t
|
||||
newframe t
|
||||
dontkill t)))
|
||||
(setq frame (make-frame-on-display
|
||||
(or display
|
||||
(frame-parameter nil 'display)
|
||||
(getenv "DISPLAY")
|
||||
(error "Please specify display"))
|
||||
(list (cons 'client proc))))
|
||||
(select-frame frame)
|
||||
(server-client-set client 'frame frame)
|
||||
(setq dontkill t))
|
||||
|
||||
;; Resume a suspended tty frame.
|
||||
;; -resume: Resume a suspended tty frame.
|
||||
((equal "-resume" arg)
|
||||
(let ((tty (cadr (assq (car client) server-ttys))))
|
||||
(let ((tty (server-client-get client 'tty)))
|
||||
(setq dontkill t)
|
||||
(when tty (resume-tty tty))))
|
||||
|
||||
;; Suspend the client's frame. (In case we get out of
|
||||
;; sync, and a C-z sends a SIGTSTP to emacsclient.)
|
||||
;; -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)
|
||||
(let ((tty (cadr (assq (car client) server-ttys))))
|
||||
(let ((tty (server-client-get client 'tty)))
|
||||
(setq dontkill t)
|
||||
(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))
|
||||
(setq dontkill t
|
||||
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))
|
||||
(let ((tty (server-unquote-arg (match-string 1 request)))
|
||||
(type (server-unquote-arg (match-string 2 request))))
|
||||
(setq request (substring request (match-end 0)))
|
||||
(unless version-checked
|
||||
(error "Protocol error; make sure to use the correct version of emacsclient"))
|
||||
(let ((frame (make-frame-on-tty tty type)))
|
||||
(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)
|
||||
;; This makes sure that `emacsclient -t -e '(delete-frame)'' works right.
|
||||
(push client server-clients)
|
||||
(setq registered t
|
||||
dontkill t
|
||||
newframe t))))
|
||||
(unless (server-client-get client 'version)
|
||||
(error "Protocol error; make sure you use the correct version of emacsclient"))
|
||||
(setq frame (make-frame-on-tty tty type (list (cons 'client proc))))
|
||||
(select-frame frame)
|
||||
(server-client-set client 'frame frame)
|
||||
(server-client-set client 'tty (frame-tty-name frame))
|
||||
;; Reply with our pid.
|
||||
(process-send-string proc (concat "-emacs-pid " (number-to-string (emacs-pid)) "\n"))
|
||||
(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))
|
||||
(setq request (substring request (match-end 0))
|
||||
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))
|
||||
(setq request (substring request (match-end 0))
|
||||
lineno (string-to-int (match-string 1 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))
|
||||
(let ((file (server-unquote-arg (match-string 1 request))))
|
||||
(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
|
||||
columnno 0))
|
||||
|
||||
;; ARG is a Lisp expression.
|
||||
;; -eval EXPR: Evaluate a Lisp expression.
|
||||
((and (equal "-eval" arg) (string-match "\\([^ ]+\\) " request))
|
||||
(let ((expr (server-unquote-arg (match-string 1 request))))
|
||||
(setq request (substring request (match-end 0)))
|
||||
(if coding-system
|
||||
(setq expr (decode-coding-string expr coding-system)))
|
||||
(let ((v (eval (car (read-from-string expr)))))
|
||||
(when (and (not newframe) v)
|
||||
(when (and (not frame) v)
|
||||
(with-temp-buffer
|
||||
(let ((standard-output (current-buffer)))
|
||||
(pp v)
|
||||
@ -520,6 +551,19 @@ PROC is the server process. Format of STRING is \"PATH PATH PATH... \\n\"."
|
||||
(setq lineno 1
|
||||
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.
|
||||
(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)
|
||||
(run-hooks 'post-command-hook))
|
||||
|
||||
;; CLIENT is now a list (CLIENTNUM BUFFERS...)
|
||||
|
||||
;; Delete the client if necessary.
|
||||
(cond
|
||||
;; Client requested nowait; return immediately.
|
||||
(nowait
|
||||
(delete-process proc)
|
||||
(server-log "Close nowait client" proc))
|
||||
;; This client is empty; get rid of it immediately.
|
||||
((and (not dontkill) (null (cdr client)))
|
||||
(delete-process proc)
|
||||
(server-log "Close empty client" proc))
|
||||
((not registered)
|
||||
(push client server-clients)))
|
||||
|
||||
;; We visited some buffer for this client.
|
||||
(cond
|
||||
((or isearch-mode (minibufferp))
|
||||
nil)
|
||||
((and newframe (null (cdr client)))
|
||||
(message (substitute-command-keys
|
||||
"When done with this frame, type \\[delete-frame]")))
|
||||
((not (null (cdr client)))
|
||||
(server-switch-buffer (nth 1 client))
|
||||
(run-hooks 'server-switch-hook)
|
||||
(unless nowait
|
||||
(message (substitute-command-keys
|
||||
"When done with a buffer, type \\[server-edit]")))))))
|
||||
;; Client requested nowait; return immediately.
|
||||
(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.
|
||||
(server-log "Close empty client" proc)
|
||||
(server-delete-client proc))
|
||||
(t
|
||||
(let ((buffers (server-client-get client 'buffers)))
|
||||
(when buffers
|
||||
;; We visited some buffer for this client.
|
||||
(cond
|
||||
((or isearch-mode (minibufferp))
|
||||
nil)
|
||||
((and frame (null buffers))
|
||||
(message (substitute-command-keys
|
||||
"When done with this frame, type \\[delete-frame]")))
|
||||
((not (null buffers))
|
||||
(server-switch-buffer (car buffers))
|
||||
(run-hooks 'server-switch-hook)
|
||||
(unless nowait
|
||||
(message (substitute-command-keys
|
||||
"When done with a buffer, type \\[server-edit]")))))))))))
|
||||
|
||||
;; Save for later any partial line that remains.
|
||||
(when (> (length string) 0)
|
||||
@ -599,8 +642,7 @@ so don't mark these buffers specially, just visit them normally."
|
||||
(revert-buffer t nil)))
|
||||
(t
|
||||
(if (y-or-n-p
|
||||
(concat "File no longer exists: "
|
||||
filen
|
||||
(concat "File no longer exists: " filen
|
||||
", write buffer to file? "))
|
||||
(write-file filen))))
|
||||
(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)
|
||||
(push (car client) server-buffer-clients))
|
||||
(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)
|
||||
"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).
|
||||
FOR-KILLING if non-nil indicates that we are called from `kill-buffer'."
|
||||
(let ((next-buffer nil)
|
||||
(killed nil)
|
||||
(old-clients server-clients))
|
||||
(while old-clients
|
||||
(let ((client (car old-clients)))
|
||||
(killed nil))
|
||||
(dolist (client server-clients)
|
||||
(let ((buffers (server-client-get client 'buffers)))
|
||||
(or next-buffer
|
||||
(setq next-buffer (nth 1 (memq buffer client))))
|
||||
(delq buffer client)
|
||||
;; Delete all dead buffers from CLIENT.
|
||||
(let ((tail client))
|
||||
(while tail
|
||||
(and (bufferp (car tail))
|
||||
(null (buffer-name (car tail)))
|
||||
(delq (car tail) client))
|
||||
(setq tail (cdr tail))))
|
||||
;; If client now has no pending buffers,
|
||||
;; tell it that it is done, and forget it entirely.
|
||||
(unless (cdr client)
|
||||
(let ((tty (cadr (assq (car client) server-ttys)))
|
||||
(frame (cadr (assq (car client) server-frames))))
|
||||
(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)))
|
||||
(setq next-buffer (nth 1 (memq buffer buffers))))
|
||||
(when buffers ; Ignore bufferless clients.
|
||||
(setq buffers (delq buffer buffers))
|
||||
;; Delete all dead buffers from CLIENT.
|
||||
(dolist (b buffers)
|
||||
(and (bufferp b)
|
||||
(not (buffer-live-p b))
|
||||
(setq buffers (delq b buffers))))
|
||||
(server-client-set client 'buffers buffers)
|
||||
;; If client now has no pending buffers,
|
||||
;; tell it that it is done, and forget it entirely.
|
||||
(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
|
||||
@ -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
|
||||
;; using whatever is on disk in that file. -- rms.
|
||||
(defun server-kill-buffer-query-function ()
|
||||
"Ask before killing a server buffer."
|
||||
(or (not server-buffer-clients)
|
||||
(let ((res t))
|
||||
(dolist (proc server-buffer-clients res)
|
||||
(setq proc (assq proc server-clients))
|
||||
(when (and proc (eq (process-status (car proc)) 'open))
|
||||
(setq res nil))))
|
||||
(let ((client (server-client proc)))
|
||||
(when (and client (eq (process-status proc) 'open))
|
||||
(setq res nil)))))
|
||||
(yes-or-no-p (format "Buffer `%s' still has clients; kill it? "
|
||||
(buffer-name (current-buffer))))))
|
||||
|
||||
(add-hook 'kill-buffer-query-functions
|
||||
'server-kill-buffer-query-function)
|
||||
|
||||
(defun server-kill-emacs-query-function ()
|
||||
(let (live-client
|
||||
(tail server-clients))
|
||||
;; See if any clients have any buffers that are still alive.
|
||||
(while tail
|
||||
(if (memq t (mapcar 'stringp (mapcar 'buffer-name (cdr (car tail)))))
|
||||
(setq live-client t))
|
||||
(setq tail (cdr tail)))
|
||||
(or (not live-client)
|
||||
(yes-or-no-p "Server buffers still have clients; exit anyway? "))))
|
||||
|
||||
(add-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function)
|
||||
"Ask before exiting Emacs it has are live clients."
|
||||
(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))))
|
||||
(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.")
|
||||
@ -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"
|
||||
;; since we've already effectively done that.
|
||||
(if (null next-buffer)
|
||||
(if server-clients
|
||||
(let ((buffer (nth 1 (car server-clients))))
|
||||
(and buffer (server-switch-buffer buffer killed-one)))
|
||||
(unless (or killed-one (window-dedicated-p (selected-window)))
|
||||
(switch-to-buffer (other-buffer))
|
||||
(progn
|
||||
(let ((rest server-clients))
|
||||
(while (and rest (not next-buffer))
|
||||
(let ((client (car rest)))
|
||||
;; 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")))
|
||||
(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
|
||||
;; and try the next surviving server 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 ()
|
||||
(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-emacs-query-functions 'server-kill-emacs-query-function)
|
||||
(remove-hook 'kill-buffer-hook 'server-kill-buffer))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user