Merged from miles@gnu.org--gnu-2005 (patch 119)
[bpt/emacs.git] / lisp / server.el
index bfedacb..f0ce3c6 100644 (file)
@@ -123,7 +123,7 @@ If it is a frame, use the frame's selected window.
 It is not meaningful to set this to a specific frame or window with Custom.
 Only programs can do so."
   :group 'server
-  :version "21.4"
+  :version "22.1"
   :type '(choice (const :tag "Use selected window"
                        :match (lambda (widget value)
                                 (not (functionp value)))
@@ -209,6 +209,46 @@ New clients have no properties."
     (setq server-clients (cons (cons proc nil)
                               server-clients))))
 
+;;;###autoload
+(defun server-getenv (variable &optional frame)
+  "Get the value of VARIABLE in the client environment of frame FRAME.
+VARIABLE should be a string.  Value is nil if VARIABLE is undefined in
+the environment.  Otherwise, value is a string.
+
+If FRAME is an emacsclient frame, then the variable is looked up
+in the environment of the emacsclient process; otherwise the
+function consults the environment of the Emacs process.
+
+If FRAME is nil or missing, then the selected frame is used."
+  (when (not frame) (setq frame (selected-frame)))
+  (let ((client (frame-parameter frame 'client)) env)
+    (if (null client)
+       (getenv variable)
+      (setq env (server-client-get client 'environment))
+      (if (null env)
+         (getenv variable)
+       (cdr (assoc variable env))))))
+
+(defmacro server-with-client-environment (client vars &rest body)
+  "Evaluate BODY with environment variables VARS set to those of CLIENT.
+The environment variables are then restored to their previous values.
+
+VARS should be a list of strings."
+  (declare (indent 2))
+  (let ((oldvalues (make-symbol "oldvalues"))
+       (var (make-symbol "var"))
+       (value (make-symbol "value"))
+       (pair (make-symbol "pair")))
+    `(let (,oldvalues)
+       (dolist (,var (quote ,vars))
+        (let ((,value (cdr (assoc ,var (server-client-get ,client 'environment)))))
+          (setq ,oldvalues (cons (cons ,var (getenv ,var)) ,oldvalues))
+          (setenv ,var ,value)))
+       (unwind-protect
+          (progn ,@body)
+        (dolist (,pair ,oldvalues)
+          (setenv (car ,pair) (cdr ,pair)))))))
+
 (defun server-delete-client (client &optional noframe)
   "Delete CLIENT, including its buffers, displays and frames.
 If NOFRAME is non-nil, let the frames live.  (To be used from
@@ -293,11 +333,12 @@ message."
   (dolist (proc (server-clients-with 'display display))
     (server-log (format "server-handle-suspend-tty, display %s" display) proc)
     (condition-case err
-       (process-send-string proc "-suspend \n")
+       (server-send-string proc "-suspend \n")
       (file-error (condition-case nil (server-delete-client proc) (error nil))))))
 
 (defun server-unquote-arg (arg)
-  "Remove &-quotation from ARG."
+  "Remove &-quotation from ARG.
+See `server-quote-arg' and `server-process-filter'."
   (replace-regexp-in-string
    "&." (lambda (s)
          (case (aref s 1)
@@ -310,7 +351,9 @@ message."
 (defun server-quote-arg (arg)
   "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."
+contains a space.
+
+See `server-unquote-arg' and `server-process-filter'."
   (replace-regexp-in-string
    "[-&\n ]" (lambda (s)
               (case (aref s 0)
@@ -320,6 +363,11 @@ contains a space."
                 (?\s "&_")))
    arg t t))
 
+(defun server-send-string (proc string)
+  "A wrapper around `proc-send-string' for logging."
+  (server-log (concat "Sent " string) proc)
+  (process-send-string proc string))
+
 (defun server-ensure-safe-dir (dir)
   "Make sure DIR is a directory with no race-condition issues.
 Creates the directory if necessary and makes sure:
@@ -396,15 +444,106 @@ Server mode runs a process that accepts commands from the
 `emacsclient' program.  See `server-start' and Info node `Emacs server'."
   :global t
   :group 'server
-  :version "21.4"
+  :version "22.1"
   ;; Fixme: Should this check for an existing server socket and do
   ;; nothing if there is one (for multiple Emacs sessions)?
   (server-start (not server-mode)))
 \f
 (defun server-process-filter (proc string)
   "Process a request from the server to edit some files.
-PROC is the server process.  Format of STRING is \"PATH PATH PATH... \\n\"."
-  (server-log string proc)
+PROC is the server process.  STRING consists of a sequence of
+commands prefixed by a dash.  Some commands have arguments; these
+are &-quoted and need to be decoded by `server-unquote-arg'.  The
+filter parses and executes these commands.
+
+To illustrate the protocol, here is an example command that
+emacsclient sends to create a new X frame (note that the whole
+sequence is sent on a single line):
+
+       -version 21.3.50 xterm
+       -env HOME /home/lorentey
+       -env DISPLAY :0.0
+       ... lots of other -env commands
+       -display :0.0
+       -window-system
+
+The server normally sends back the single command `-good-version'
+as a response.
+
+The following commands are accepted by the server:
+
+`-version CLIENT-VERSION'
+  Check version numbers between server and client, and signal an
+  error if there is a mismatch.  The server replies with
+  `-good-version' to confirm the match.
+
+`-env NAME VALUE'
+  An environment variable on the client side.
+
+`-nowait'
+  Request that the next frame created should not be
+  associated with this client.
+
+`-display DISPLAY'
+  Set the display name to open X frames on.
+
+`-position LINE[:COLUMN]'
+  Go to the given line and column number
+  in the next file opened.
+
+`-file FILENAME'
+  Load the given file in the current frame.
+
+`-eval EXPR'
+  Evaluate EXPR as a Lisp expression and return the
+  result in -print commands.
+
+`-window-system'
+  Open a new X frame.
+
+`-tty DEVICENAME TYPE'
+  Open a new tty frame at the client.
+
+`-resume'
+  Resume this tty frame. The client sends this string when it
+  gets the SIGCONT signal and it is the foreground process on its
+  controlling tty.
+
+`-suspend'
+  Suspend this tty frame.  The client sends this string in
+  response to SIGTSTP and SIGTTOU.  The server must cease all I/O
+  on this tty until it gets a -resume command.
+
+`-ignore COMMENT'
+  Do nothing, but put the comment in the server
+  log.  Useful for debugging.
+
+
+The following commands are accepted by the client:
+
+`-good-version'
+  Signals a version match between the client and the server.
+
+`-emacs-pid PID'
+  Describes the process id of the Emacs process;
+  used to forward window change signals to it.
+
+`-window-system-unsupported'
+  Signals that the server does not
+  support creating X frames; the client must try again with a tty
+  frame.
+
+`-print STRING'
+  Print STRING on stdout.  Used to send values
+  returned by -eval.
+
+`-error DESCRIPTION'
+  Signal an error (but continue processing).
+
+`-suspend'
+  Suspend this terminal, i.e., stop the client process.  Sent
+  when the user presses C-z."
+  (server-log (concat "Received " string) proc)
   (let ((prev (process-get proc 'previous-string)))
     (when prev
       (setq string (concat prev string))
@@ -443,7 +582,7 @@ PROC is the server process.  Format of STRING is \"PATH PATH PATH... \\n\"."
                    (setq request (substring request (match-end 0)))
                    (if (equal client-version truncated-emacs-version)
                        (progn
-                         (process-send-string proc "-good-version \n")
+                         (server-send-string proc "-good-version \n")
                          (server-client-set client 'version client-version))
                      (error (concat "Version mismatch: Emacs is "
                                     truncated-emacs-version
@@ -462,20 +601,26 @@ PROC is the server process.  Format of STRING is \"PATH PATH PATH... \\n\"."
                 ((equal "-window-system" arg)
                  (unless (server-client-get client 'version)
                    (error "Protocol error; make sure to use the correct version of emacsclient"))
-                 (setq frame (make-frame-on-display
-                              (or display
-                                  (frame-parameter nil 'display)
-                                  (getenv "DISPLAY")
-                                  (error "Please specify display"))
-                              (list (cons 'client proc))))
-                 ;; XXX We need to ensure the client parameter is
-                 ;; really set because Emacs forgets initialization
-                 ;; parameters for X frames at the moment.
-                 (modify-frame-parameters frame (list (cons 'client proc)))
-                 (select-frame frame)
-                 (server-client-set client 'frame frame)
-                 (server-client-set client 'display (frame-display frame))
-                 (setq dontkill t))
+                 (if (fboundp 'x-create-frame)
+                     (progn
+                       (setq frame (make-frame-on-display
+                                    (or display
+                                        (frame-parameter nil 'display)
+                                        (getenv "DISPLAY")
+                                        (error "Please specify display"))
+                                    (list (cons 'client proc))))
+                       ;; XXX We need to ensure the client parameter is
+                       ;; really set because Emacs forgets initialization
+                       ;; parameters for X frames at the moment.
+                       (modify-frame-parameters frame (list (cons 'client proc)))
+                       (select-frame frame)
+                       (server-client-set client 'frame frame)
+                       (server-client-set client 'display (frame-display frame))
+                       (setq dontkill t))
+                   ;; This emacs does not support X.
+                   (server-log "Window system unsupported" proc)
+                   (server-send-string proc "-window-system-unsupported \n")
+                   (setq dontkill t)))
 
                 ;; -resume:  Resume a suspended tty frame.
                 ((equal "-resume" arg)
@@ -506,7 +651,15 @@ PROC is the server process.  Format of STRING is \"PATH PATH PATH... \\n\"."
                    (setq request (substring request (match-end 0)))
                    (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))))
+                   ;; Set up client's environment for tgetent(3)
+                   ;; according to ncurses(3).
+                   (server-with-client-environment proc
+                       ("BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES"
+                        "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING"
+                        "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO"
+                        "TERMINFO_DIRS" "TERMPATH")
+                     (setq frame (make-frame-on-tty tty type
+                                                    `((client . ,proc)))))
                    (select-frame frame)
                    (server-client-set client 'frame frame)
                    (server-client-set client 'tty (display-name frame))
@@ -514,7 +667,7 @@ PROC is the server process.  Format of STRING is \"PATH PATH PATH... \\n\"."
                    ;; Set up display for the remote locale.
                    (configure-display-for-locale)
                    ;; Reply with our pid.
-                   (process-send-string proc (concat "-emacs-pid " (number-to-string (emacs-pid)) "\n"))
+                   (server-send-string proc (concat "-emacs-pid " (number-to-string (emacs-pid)) "\n"))
                    (setq dontkill t)))
 
                 ;; -position LINE:  Go to the given line in the next file.
@@ -524,9 +677,9 @@ PROC is the server process.  Format of STRING is \"PATH PATH PATH... \\n\"."
 
                 ;; -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))))
+                 (setq lineno (string-to-int (match-string 1 request))
+                       columnno (string-to-int (match-string 2 request))
+                       request (substring request (match-end 0))))
 
                 ;; -file FILENAME:  Load the given file.
                 ((and (equal "-file" arg) (string-match "\\([^ ]+\\) " request))
@@ -550,12 +703,11 @@ PROC is the server process.  Format of STRING is \"PATH PATH PATH... \\n\"."
                        (with-temp-buffer
                          (let ((standard-output (current-buffer)))
                            (pp v)
-                           (process-send-string proc "-print ")
-                           (process-send-string
-                            proc (server-quote-arg
-                                  (buffer-substring-no-properties (point-min)
-                                                                  (point-max))))
-                           (process-send-string proc "\n")))))
+                           (server-send-string
+                            proc (format "-print %s\n"
+                                         (server-quote-arg
+                                          (buffer-substring-no-properties (point-min)
+                                                                          (point-max)))))))))
                    (setq lineno 1
                          columnno 0)))
 
@@ -609,7 +761,7 @@ PROC is the server process.  Format of STRING is \"PATH PATH PATH... \\n\"."
          (process-put proc 'previous-string string)))
     ;; condition-case
     (error (ignore-errors
-            (process-send-string
+            (server-send-string
              proc (concat "-error " (server-quote-arg (error-message-string err))))
             (setq string "")
             (server-log (error-message-string err) proc)
@@ -770,7 +922,7 @@ specifically for the clients and did not exist before their request for it."
                           (buffer-name (current-buffer))))))
 
 (defun server-kill-emacs-query-function ()
-  "Ask before exiting Emacs it has are live clients."
+  "Ask before exiting Emacs it has live clients."
   (or (not server-clients)
       (let (live-client)
        (dolist (client server-clients live-client)
@@ -879,37 +1031,26 @@ done that."
   "Offer to save each buffer, then kill the current connection.
 If the current frame has no client, kill Emacs itself.
 
-With prefix arg, silently save all file-visiting buffers, then kill."
+With prefix arg, silently save all file-visiting buffers, then kill.
+
+If emacsclient was started with a list of filenames to edit, then
+only these files will be asked to be saved."
   (interactive "P")
   (let ((proc (frame-parameter (selected-frame) 'client)))
-    (if (and proc)
-       (progn
-         (save-some-buffers arg t)
+    (if proc
+       (let ((buffers (server-client-get proc 'buffers)))
+         ;; If client is bufferless, emulate a normal Emacs session
+         ;; exit and offer to save all buffers.  Otherwise, offer to
+         ;; save only the buffers belonging to the client.
+         (save-some-buffers arg
+                            (if buffers
+                                (lambda () (memq (current-buffer) buffers))
+                              t))
          (server-delete-client proc))
       (save-buffers-kill-emacs))))
 
 (global-set-key "\C-x#" 'server-edit)
 
-;;;###autoload
-(defun server-getenv (variable &optional frame)
-  "Get the value of VARIABLE in the client environment of frame FRAME.
-VARIABLE should be a string.  Value is nil if VARIABLE is undefined in
-the environment.  Otherwise, value is a string.
-
-If FRAME is an emacsclient frame, then the variable is looked up
-in the environment of the emacsclient process; otherwise the
-function consults the environment of the Emacs process.
-
-If FRAME is nil or missing, then the selected frame is used."
-  (when (not frame) (setq frame (selected-frame)))
-  (let ((client (frame-parameter frame 'client)) env)
-    (if (null client)
-       (getenv variable)
-      (setq env (server-client-get client 'environment))
-      (if (null env)
-         (getenv variable)
-       (cdr (assoc variable env))))))
-
 (defun server-unload-hook ()
   "Unload the server library."
   (server-start t)
@@ -918,6 +1059,8 @@ If FRAME is nil or missing, then the selected frame is used."
   (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))
+
+(add-hook 'server-unload-hook 'server-unload-hook)
 \f
 (provide 'server)