Emacs server without emacsserver.

[Stefan Monnier]

If someone wants to play with it, here is a first cut at it.
I wish we could attach arbitrary properties to processes as we
can to symbols, frames, overlays, ...


        Stefan


--- server.el.~1.79.~   Mon Aug 19 13:45:36 2002
+++ server.el   Tue Sep 17 16:06:40 2002
@@ -76,15 +76,12 @@
 
 ;;; Code:
 
+(eval-when-compile (require 'cl))
+
 (defgroup server nil
   "Emacs running as a server process."
   :group 'external)
 
-(defcustom server-program (expand-file-name "emacsserver" exec-directory)
-  "*The program to use as the edit server."
-  :group 'server
-  :type 'string)
-
 (defcustom server-visit-hook nil
   "*List of hooks to call when visiting a file for the Emacs server."
   :group 'server
@@ -103,7 +100,7 @@
 (defvar server-process nil 
   "The current server process")
 
-(defvar server-previous-string "")
+(defvar server-previous-strings nil)
 
 (defvar server-clients nil
   "List of current server clients.
@@ -151,21 +148,32 @@
 where it is set.")
 (make-variable-buffer-local 'server-existing-buffer)
 
+(defvar server-socket-name
+  (if (or (not (file-writable-p "~/"))
+         (and (file-writable-p "/tmp/")
+              (not (zerop (logand (file-modes "/tmp/") 512)))))
+      (format "/tmp/esrv%d-%s" (user-uid) (system-name))
+    (format "~/.emacs-server-%s" (system-name))))
+
 ;; If a *server* buffer exists,
 ;; write STRING to it for logging purposes.
 (defun server-log (string)
   (if (get-buffer "*server*")
-      (save-excursion
-       (set-buffer "*server*")
+      (with-current-buffer "*server*"
        (goto-char (point-max))
        (insert (current-time-string) " " string)
        (or (bolp) (newline)))))
 
 (defun server-sentinel (proc msg)
-  (cond ((eq (process-status proc) 'exit)
-        (server-log (message "Server subprocess exited")))
-       ((eq (process-status proc) 'signal)
-        (server-log (message "Server subprocess killed")))))
+  (let ((ps (assq proc server-previous-strings)))
+    (if ps (setq server-previous-strings
+                (delq ps server-previous-strings))))
+  (case (process-status proc)
+    (exit (server-log (message "Server subprocess exited")))
+    (signal (server-log (message "Server subprocess killed")))
+    (closed (server-log (message "Server connection closed")))
+    (t (server-log (message "Server status changed to %s (%s)"
+                           (process-status proc) msg)))))
 
 ;;;###autoload
 (defun server-start (&optional leave-dead)
@@ -183,24 +191,7 @@
        (set-process-sentinel server-process nil)
        (condition-case () (delete-process server-process) (error nil))))
   ;; Delete the socket files made by previous server invocations.
-  (let* ((sysname (system-name))
-        (dot-index (string-match "\\." sysname)))
-    (condition-case ()
-       (delete-file (format "~/.emacs-server-%s" sysname))
-      (error nil))
-    (condition-case ()
-       (delete-file (format "/tmp/esrv%d-%s" (user-uid) sysname))
-      (error nil))
-    ;; In case the server file name was made with a domainless hostname,
-    ;; try deleting that name too.
-    (if dot-index
-       (let ((shortname (substring sysname 0 dot-index)))
-         (condition-case ()
-             (delete-file (format "~/.emacs-server-%s" shortname))
-           (error nil))
-         (condition-case ()
-             (delete-file (format "/tmp/esrv%d-%s" (user-uid) shortname))
-           (error nil)))))
+  (condition-case () (delete-file server-socket-name) (error nil))
   ;; If this Emacs already had a server, clear out associated status.
   (while server-clients
     (let ((buffer (nth 1 (car server-clients))))
@@ -211,21 +202,29 @@
        (server-log (message "Restarting server")))
     ;; Using a pty is wasteful, and the separate session causes
     ;; annoyance sometimes (some systems kill idle sessions).
-    (let ((process-connection-type nil))
-      (setq server-process (start-process "server" nil server-program)))
-    (set-process-sentinel server-process 'server-sentinel)
-    (set-process-filter server-process 'server-process-filter)
-    ;; We must receive file names without being decoded.  Those are
-    ;; decoded by server-process-filter accoding to
-    ;; file-name-coding-system.
-    (set-process-coding-system server-process 'raw-text 'raw-text)
-    (process-kill-without-query server-process)))
+    (let ((umask (default-file-modes)))
+      (unwind-protect
+         (progn
+           (set-default-file-modes ?\700)
+           (setq server-process
+                 (make-network-process
+                  :name "server" :family 'local :server t :noquery t
+                  :service server-socket-name
+                  :sentinel 'server-sentinel :filter 'server-process-filter
+                  ;; We must receive file names without being decoded.
+                  ;; Those are decoded by server-process-filter according
+                  ;; to file-name-coding-system.
+                  :coding 'raw-text)))
+       (set-default-file-modes umask)))))
 
 ;Process a request from the server to edit some files.
 ;Format of STRING is "Client: CLIENTID PATH PATH PATH... \n"
 (defun server-process-filter (proc string)
   (server-log string)
-  (setq string (concat server-previous-string string))
+  (let ((ps (assq proc server-previous-strings)))
+    (when (cdr ps)
+      (setq string (concat (cdr ps) string))
+      (setcdr ps nil)))
   ;; If the input is multiple lines,
   ;; process each line individually.
   (while (string-match "\n" string)
@@ -239,13 +238,7 @@
          (columnno 0))
       ;; Remove this line from STRING.
       (setq string (substring string (match-end 0)))     
-      (if (string-match "^Error: " request)
-         (message "Server error: %s" (substring request (match-end 0)))
-       (if (string-match "^Client: " request)
-           (progn
-             (setq request (substring request (match-end 0)))
-             (setq client (list (substring request 0 (string-match " " 
request))))
-             (setq request (substring request (match-end 0)))
+      (setq client (cons proc nil))
              (while (string-match "[^ ]+ " request)
                (let ((arg
                       (substring request (match-beginning 0) (1- (match-end 
0))))
@@ -300,9 +293,12 @@
                (server-switch-buffer (nth 1 client))
                (run-hooks 'server-switch-hook)
                (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.
-  (setq server-previous-string string))
+  (when (> (length string) 0)
+    (let ((ps (assq proc server-previous-strings)))
+      (if ps (setcdr ps string)
+       (push (cons proc string) server-previous-strings)))))
 
 (defun server-goto-line-column (file-line-col)
   (goto-line (nth 1 file-line-col))
@@ -356,12 +352,11 @@
   "Mark BUFFER as \"done\" for its client(s).
 This buries the buffer, then returns a list of the form (NEXT-BUFFER KILLED).
 NEXT-BUFFER is another server buffer, as a suggestion for what to select next,
-or nil.  KILLED is t if we killed BUFFER
-\(typically, because it was visiting a temp file)."
-  (let ((running (eq (process-status server-process) 'run))
-       (next-buffer nil)
+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)
-       (first t)
        (old-clients server-clients))
     (while old-clients
       (let ((client (car old-clients)))
@@ -377,16 +372,9 @@
            (setq tail (cdr tail))))
        ;; If client now has no pending buffers,
        ;; tell it that it is done, and forget it entirely.
-       (if (cdr client) nil
-         (if running
-             (progn
-               ;; Don't send emacsserver two commands in close succession.
-               ;; It cannot handle that.
-               (or first (sit-for 1))
-               (setq first nil)
-               (send-string server-process 
-                            (format "Close: %s Done\n" (car client)))
-               (server-log (format "Close: %s Done\n" (car client)))))
+       (unless (cdr client)
+         (delete-process (car client))
+         (server-log (format "Close: %s Done\n" (car client)))
          (setq server-clients (delq client server-clients))))
       (setq old-clients (cdr old-clients)))
     (if (and (bufferp buffer) (buffer-name buffer))