Commit 9002956f authored by Karoly Lorentey's avatar Karoly Lorentey
Browse files

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
parent 6839f1e2
......@@ -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 ");
......
......@@ -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
(setq frame (make-frame-on-display
(or display
(frame-parameter nil 'display)
(getenv "DISPLAY")
(error "Please specify display")))))
(push (list proc frame) server-frames)
(error "Please specify display"))
(list (cons 'client proc))))
(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)))
(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"))
(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)
;; This makes sure that `emacsclient -t -e '(delete-frame)'' works right.
(push client server-clients)
(setq registered t
dontkill t
newframe t))))
(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))
;; 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.
((and (not dontkill) (null (cdr client)))
(delete-process proc)
(server-log "Close empty client" proc))
((not registered)
(push client server-clients)))
(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 newframe (null (cdr client)))
((and frame (null buffers))
(message (substitute-command-keys
"When done with this frame, type \\[delete-frame]")))
((not (null (cdr client)))