server.el 69 KB
Newer Older
Stefan Monnier's avatar
Stefan Monnier committed
1
;;; server.el --- Lisp code for GNU Emacs running as server process -*- lexical-binding: t -*-
Eric S. Raymond's avatar
Eric S. Raymond committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1986-1987, 1992, 1994-2018 Free Software Foundation,
4
;; Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
5

Eric S. Raymond's avatar
Eric S. Raymond committed
6
;; Author: William Sommerfeld <wesommer@athena.mit.edu>
7
;; Maintainer: emacs-devel@gnu.org
Eric S. Raymond's avatar
Eric S. Raymond committed
8
;; Keywords: processes
Eric S. Raymond's avatar
Eric S. Raymond committed
9

root's avatar
root committed
10
;; Changes by peck@sun.com and by rms.
11
;; Overhaul by Karoly Lorentey <lorentey@elte.hu> for multi-tty support.
root's avatar
root committed
12 13 14

;; This file is part of GNU Emacs.

15
;; GNU Emacs is free software: you can redistribute it and/or modify
root's avatar
root committed
16
;; it under the terms of the GNU General Public License as published by
17 18
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
root's avatar
root committed
19 20 21 22 23 24 25

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
26
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
root's avatar
root committed
27

Eric S. Raymond's avatar
Eric S. Raymond committed
28
;;; Commentary:
root's avatar
root committed
29

Erik Naggum's avatar
Erik Naggum committed
30 31
;; This Lisp code is run in Emacs when it is to operate as
;; a server for other processes.
root's avatar
root committed
32

Erik Naggum's avatar
Erik Naggum committed
33
;; Load this library and do M-x server-edit to enable Emacs as a server.
34 35 36
;; Emacs opens up a socket for communication with clients.  If there are no
;; client buffers to edit, server-edit acts like (switch-to-buffer
;; (other-buffer))
root's avatar
root committed
37

Erik Naggum's avatar
Erik Naggum committed
38 39 40 41
;; When some other program runs "the editor" to edit a file,
;; "the editor" can be the Emacs client program ../lib-src/emacsclient.
;; This program transmits the file names to Emacs through
;; the server subprocess, and Emacs visits them and lets you edit them.
root's avatar
root committed
42

Karoly Lorentey's avatar
Karoly Lorentey committed
43
;; Note that any number of clients may dispatch files to Emacs to be edited.
root's avatar
root committed
44

Erik Naggum's avatar
Erik Naggum committed
45
;; When you finish editing a Server buffer, again call server-edit
46 47
;; to mark that buffer as done for the client and switch to the next
;; Server buffer.  When all the buffers for a client have been edited
Erik Naggum's avatar
Erik Naggum committed
48
;; and exited with server-edit, the client "editor" will return
49
;; to the program that invoked it.
root's avatar
root committed
50

Erik Naggum's avatar
Erik Naggum committed
51 52 53 54
;; Your editing commands and Emacs's display output go to and from
;; the terminal in the usual way.  Thus, server operation is possible
;; only when Emacs can talk to the terminal at the time you invoke
;; the client.  This is possible in four cases:
root's avatar
root committed
55

Erik Naggum's avatar
Erik Naggum committed
56 57
;; 1. On a window system, where Emacs runs in one window and the
;; program that wants to use "the editor" runs in another.
root's avatar
root committed
58

Erik Naggum's avatar
Erik Naggum committed
59 60
;; 2. On a multi-terminal system, where Emacs runs on one terminal and the
;; program that wants to use "the editor" runs on another.
root's avatar
root committed
61

Erik Naggum's avatar
Erik Naggum committed
62 63
;; 3. When the program that wants to use "the editor" is running
;; as a subprocess of Emacs.
root's avatar
root committed
64

Erik Naggum's avatar
Erik Naggum committed
65 66 67 68 69
;; 4. On a system with job control, when Emacs is suspended, the program
;; that wants to use "the editor" will stop and display
;; "Waiting for Emacs...".  It can then be suspended, and Emacs can be
;; brought into the foreground for editing.  When done editing, Emacs is
;; suspended again, and the client program is brought into the foreground.
root's avatar
root committed
70

71 72
;; The buffer local variable "server-buffer-clients" lists
;; the clients who are waiting for this buffer to be edited.
Erik Naggum's avatar
Erik Naggum committed
73 74
;; The global variable "server-clients" lists all the waiting clients,
;; and which files are yet to be edited for each.
Eric S. Raymond's avatar
Eric S. Raymond committed
75

Stefan Monnier's avatar
Stefan Monnier committed
76 77 78 79 80 81 82
;; Todo:

;; - handle command-line-args-left.
;; - move most of the args processing and decision making from emacsclient.c
;;   to here.
;; - fix up handling of the client's environment (place it in the terminal?).

Eric S. Raymond's avatar
Eric S. Raymond committed
83
;;; Code:
84

85
(eval-when-compile (require 'cl-lib))
86

Richard M. Stallman's avatar
Richard M. Stallman committed
87 88 89 90
(defgroup server nil
  "Emacs running as a server process."
  :group 'external)

91 92 93 94 95 96 97 98 99 100 101 102 103 104
(defcustom server-use-tcp nil
  "If non-nil, use TCP sockets instead of local sockets."
  :set #'(lambda (sym val)
           (unless (featurep 'make-network-process '(:family local))
             (setq val t)
             (unless load-in-progress
               (message "Local sockets unsupported, using TCP sockets")))
           (set-default sym val))
  :group 'server
  :type 'boolean
  :version "22.1")

(defcustom server-host nil
  "The name or IP address to use as host address of the server process.
105 106
If set, the server accepts remote connections; otherwise it is local.

Juanma Barranquero's avatar
Juanma Barranquero committed
107 108 109 110
DO NOT give this a non-nil value unless you know what you are doing!
On unsecured networks, accepting remote connections is very dangerous,
because server-client communication (including session authentication)
is not encrypted."
111 112 113 114 115
  :group 'server
  :type '(choice
          (string :tag "Name or IP address")
          (const :tag "Local" nil))
  :version "22.1")
116
;;;###autoload
117 118
(put 'server-host 'risky-local-variable t)

119
(defcustom server-port nil
120 121 122 123
  "The port number that the server process should listen on.
This variable only takes effect when the Emacs server is using
TCP instead of local sockets.  A nil value means to use a random
port number."
124 125 126 127 128
  :group 'server
  :type '(choice
          (string :tag "Port number")
          (const :tag "Random" nil))
  :version "24.1")
129 130
;;;###autoload
(put 'server-port 'risky-local-variable t)
131

132
(defcustom server-auth-dir (locate-user-emacs-file "server/")
133
  "Directory for server authentication files.
Glenn Morris's avatar
Glenn Morris committed
134 135
We only use this if `server-use-tcp' is non-nil.
Otherwise we use `server-socket-dir'.
136 137 138 139 140

NOTE: On FAT32 filesystems, directories are not secure;
files can be read and modified by any user or process.
It is strongly suggested to set `server-auth-dir' to a
directory residing in a NTFS partition instead."
141 142 143
  :group 'server
  :type 'directory
  :version "22.1")
144
;;;###autoload
145 146
(put 'server-auth-dir 'risky-local-variable t)

147 148
(defcustom server-auth-key nil
  "Server authentication key.
149
This is only used if `server-use-tcp' is non-nil.
150

151
Normally, the authentication key is randomly generated when the
152 153 154
server starts.  It is recommended to leave it that way.  Using a
long-lived shared key will decrease security (especially since
the key is transmitted as plain-text).
155 156

In some situations however, it can be difficult to share randomly
157
generated passwords with remote hosts (e.g., no shared directory),
158 159 160
so you can set the key with this variable and then copy the
server file to the remote host (with possible changes to IP
address and/or port if that applies).
161

162 163 164
Note that the usual security risks of using the server over
remote TCP, arising from the fact that client-server
communications are unencrypted, still apply.
165

166 167 168
The key must consist of 64 ASCII printable characters except for
space (this means characters from ! to ~; or from code 33 to
126).  You can use \\[server-generate-key] to get a random key."
169 170 171 172
  :group 'server
  :type '(choice
	  (const :tag "Random" nil)
	  (string :tag "Password"))
173
  :version "24.3")
174

175
(defcustom server-raise-frame t
176
  "If non-nil, raise frame when switching to a buffer."
177 178 179 180
  :group 'server
  :type 'boolean
  :version "22.1")

Richard M. Stallman's avatar
Richard M. Stallman committed
181
(defcustom server-visit-hook nil
182
  "Hook run when visiting a file for the Emacs server."
Richard M. Stallman's avatar
Richard M. Stallman committed
183
  :group 'server
184
  :type 'hook)
Richard M. Stallman's avatar
Richard M. Stallman committed
185 186

(defcustom server-switch-hook nil
187
  "Hook run when switching to a buffer for the Emacs server."
Richard M. Stallman's avatar
Richard M. Stallman committed
188
  :group 'server
189
  :type 'hook)
Richard M. Stallman's avatar
Richard M. Stallman committed
190

191 192 193 194 195 196 197
(defcustom server-after-make-frame-hook nil
  "Hook run when the Emacs server creates a client frame.
The created frame is selected when the hook is called."
  :group 'server
  :type 'hook
  :version "27.1")

Richard M. Stallman's avatar
Richard M. Stallman committed
198
(defcustom server-done-hook nil
199
  "Hook run when done editing a buffer for the Emacs server."
Richard M. Stallman's avatar
Richard M. Stallman committed
200
  :group 'server
201
  :type 'hook)
202

203 204
(defvar server-process nil
  "The current server process.")
root's avatar
root committed
205 206 207

(defvar server-clients nil
  "List of current server clients.
208
Each element is a process.")
Karoly Lorentey's avatar
Karoly Lorentey committed
209

root's avatar
root committed
210
(defvar server-buffer-clients nil
211
  "List of client processes requesting editing of current buffer.")
212
(make-variable-buffer-local 'server-buffer-clients)
root's avatar
root committed
213 214 215
;; Changing major modes should not erase this local.
(put 'server-buffer-clients 'permanent-local t)

Dave Love's avatar
Dave Love committed
216
(defcustom server-window nil
217
  "Specification of the window to use for selecting Emacs server buffers.
218
If nil, use the selected window.
219
If it is a function, it should take one argument (a buffer) and
Dave Love's avatar
Dave Love committed
220 221 222 223 224 225 226
display and select it.  A common value is `pop-to-buffer'.
If it is a window, use that.
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
227
  :version "22.1"
Dave Love's avatar
Dave Love committed
228 229 230 231
  :type '(choice (const :tag "Use selected window"
			:match (lambda (widget value)
				 (not (functionp value)))
			nil)
232
		 (function-item :tag "Display in new frame" switch-to-buffer-other-frame)
Dave Love's avatar
Dave Love committed
233 234
		 (function-item :tag "Use pop-to-buffer" pop-to-buffer)
		 (function :tag "Other function")))
235

Richard M. Stallman's avatar
Richard M. Stallman committed
236
(defcustom server-temp-file-regexp "^/tmp/Re\\|/draft$"
237
  "Regexp matching names of temporary files.
Dave Love's avatar
Dave Love committed
238 239
These are deleted and reused after each edit by the programs that
invoke the Emacs server."
Richard M. Stallman's avatar
Richard M. Stallman committed
240 241
  :group 'server
  :type 'regexp)
root's avatar
root committed
242

243
(defcustom server-kill-new-buffers t
244
  "Whether to kill buffers when done with them.
245
If non-nil, kill a buffer unless it already existed before editing
246
it with the Emacs server.  If nil, kill only buffers as specified by
247
`server-temp-file-regexp'.
248
Please note that only buffers that still have a client are killed,
249 250
i.e. buffers visited with \"emacsclient --no-wait\" are never killed
in this way."
251 252 253 254 255
  :group 'server
  :type 'boolean
  :version "21.1")

(defvar server-existing-buffer nil
256
  "Non-nil means the buffer existed before the server was asked to visit it.
257
This means that the server should not kill the buffer when you say you
258
are done with it in the server.")
259 260
(make-variable-buffer-local 'server-existing-buffer)

261
(defvar server--external-socket-initialized nil
262
  "When an external socket is passed into Emacs, we need to call
263 264
`server-start' in order to initialize the connection.  This flag
prevents multiple initializations when an external socket has
265 266 267
been consumed.")

(defcustom server-name
268 269
  (if internal--daemon-sockname
      (file-name-nondirectory internal--daemon-sockname)
270
    "server")
271 272 273 274 275 276
  "The name of the Emacs server, if this Emacs process creates one.
The command `server-start' makes use of this.  It should not be
changed while a server is running."
  :group 'server
  :type 'string
  :version "23.1")
Stefan Monnier's avatar
Stefan Monnier committed
277

Chong Yidong's avatar
Chong Yidong committed
278 279
;; We do not use `temporary-file-directory' here, because emacsclient
;; does not read the init file.
280
(defvar server-socket-dir
281 282
  (if internal--daemon-sockname
      (file-name-directory internal--daemon-sockname)
283 284
    (and (featurep 'make-network-process '(:family local))
         (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid))))
285 286
  "The directory in which to place the server socket.
If local sockets are not supported, this is nil.")
287

Karoly Lorentey's avatar
Karoly Lorentey committed
288 289 290
(defun server-clients-with (property value)
  "Return a list of clients with PROPERTY set to VALUE."
  (let (result)
291
    (dolist (proc server-clients)
292
      (when (equal value (process-get proc property))
293 294
	(push proc result)))
    result))
Karoly Lorentey's avatar
Karoly Lorentey committed
295 296 297 298

(defun server-add-client (proc)
  "Create a client for process PROC, if it doesn't already have one.
New clients have no properties."
299
  (add-to-list 'server-clients proc))
Karoly Lorentey's avatar
Karoly Lorentey committed
300

301 302
(defmacro server-with-environment (env vars &rest body)
  "Evaluate BODY with environment variables VARS set to those in ENV.
303 304
The environment variables are then restored to their previous values.

305 306
VARS should be a list of strings.
ENV should be in the same format as `process-environment'."
307
  (declare (indent 2))
308 309 310
  (let ((var (make-symbol "var"))
	(value (make-symbol "value")))
    `(let ((process-environment process-environment))
311
       (dolist (,var ,vars)
312
         (let ((,value (getenv-internal ,var ,env)))
313 314 315
           (push (if (stringp ,value)
                     (concat ,var "=" ,value)
                   ,var)
316 317
                 process-environment)))
       (progn ,@body))))
318

319
(defun server-delete-client (proc &optional noframe)
320
  "Delete PROC, including its buffers, terminals and frames.
321 322
If NOFRAME is non-nil, let the frames live.
Updates `server-clients'."
323
  (server-log (concat "server-delete-client" (if noframe " noframe")) proc)
Karoly Lorentey's avatar
Karoly Lorentey committed
324
  ;; Force a new lookup of client (prevents infinite recursion).
325 326
  (when (memq proc server-clients)
    (let ((buffers (process-get proc 'buffers)))
Karoly Lorentey's avatar
Karoly Lorentey committed
327

328
      ;; Kill the client's buffers.
Karoly Lorentey's avatar
Karoly Lorentey committed
329
      (dolist (buf buffers)
330 331 332
	(when (buffer-live-p buf)
	  (with-current-buffer buf
	    ;; Kill the buffer if necessary.
333 334
	    (when (and (equal server-buffer-clients
			      (list proc))
335 336
		       (or (and server-kill-new-buffers
				(not server-existing-buffer))
337 338 339 340 341 342 343 344 345 346
			   (server-temp-file-p))
		       (not (buffer-modified-p)))
	      (let (flag)
		(unwind-protect
		    (progn (setq server-buffer-clients nil)
			   (kill-buffer (current-buffer))
			   (setq flag t))
		  (unless flag
		    ;; Restore clients if user pressed C-g in `kill-buffer'.
		    (setq server-buffer-clients (list proc)))))))))
Karoly Lorentey's avatar
Karoly Lorentey committed
347

348 349 350 351 352 353 354 355 356 357
      ;; Delete the client's frames.
      (unless noframe
	(dolist (frame (frame-list))
	  (when (and (frame-live-p frame)
		     (equal proc (frame-parameter frame 'client)))
	    ;; Prevent `server-handle-delete-frame' from calling us
	    ;; recursively.
	    (set-frame-parameter frame 'client nil)
	    (delete-frame frame))))

358
      (setq server-clients (delq proc server-clients))
359

360 361 362 363 364 365 366
      ;; Delete the client's tty, except on Windows (both GUI and console),
      ;; where there's only one terminal and does not make sense to delete it.
      (unless (eq system-type 'windows-nt)
	(let ((terminal (process-get proc 'terminal)))
	  ;; Only delete the terminal if it is non-nil.
	  (when (and terminal (eq (terminal-live-p terminal) t))
	    (delete-terminal terminal))))
Karoly Lorentey's avatar
Karoly Lorentey committed
367 368

      ;; Delete the client's process.
369 370
      (if (eq (process-status proc) 'open)
	  (delete-process proc))
Karoly Lorentey's avatar
Karoly Lorentey committed
371 372 373

      (server-log "Deleted" proc))))

374
(defvar server-log-time-function 'current-time-string
375
  "Function to generate timestamps for `server-buffer'.")
376

Stefan Monnier's avatar
Stefan Monnier committed
377 378
(defconst server-buffer " *server*"
  "Buffer used internally by Emacs's server.
379
One use is to log the I/O for debugging purposes (see option `server-log'),
Stefan Monnier's avatar
Stefan Monnier committed
380
the other is to provide a current buffer in which the process filter can
381
safely let-bind buffer-local variables like `default-directory'.")
Stefan Monnier's avatar
Stefan Monnier committed
382 383 384 385

(defvar server-log nil
  "If non-nil, log the server's inputs and outputs in the `server-buffer'.")

386
(defun server-log (string &optional client)
387
  "If option `server-log' is non-nil, log STRING to `server-buffer'.
388
If CLIENT is non-nil, add a description of it to the logged message."
Stefan Monnier's avatar
Stefan Monnier committed
389 390
  (when server-log
    (with-current-buffer (get-buffer-create server-buffer)
391
      (goto-char (point-max))
392
      (insert (funcall server-log-time-function)
393
	      (cond
394 395 396
	       ((null client) " ")
	       ((listp client) (format " %s: " (car client)))
	       (t (format " %s: " client)))
397 398
	      string)
      (or (bolp) (newline)))))
root's avatar
root committed
399 400

(defun server-sentinel (proc msg)
Karoly Lorentey's avatar
Karoly Lorentey committed
401
  "The process sentinel for Emacs server connections."
402 403 404 405 406
  ;; If this is a new client process, set the query-on-exit flag to nil
  ;; for this process (it isn't inherited from the server process).
  (when (and (eq (process-status proc) 'open)
	     (process-query-on-exit-flag proc))
    (set-process-query-on-exit-flag proc nil))
407
  ;; Delete the associated connection file, if applicable.
408 409 410 411 412
  ;; Although there's no 100% guarantee that the file is owned by the
  ;; running Emacs instance, server-start uses server-running-p to check
  ;; for possible servers before doing anything, so it *should* be ours.
  (and (process-contact proc :server)
       (eq (process-status proc) 'closed)
413
       (ignore-errors
414
	 (delete-file (process-get proc :server-file))))
Karoly Lorentey's avatar
Karoly Lorentey committed
415 416
  (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
  (server-delete-client proc))
417

418 419 420 421 422 423 424 425 426
(defun server--on-display-p (frame display)
  (and (equal (frame-parameter frame 'display) display)
       ;; Note: TTY frames still get a `display' parameter set to the value of
       ;; $DISPLAY.  This is useful when running from that tty frame
       ;; sub-processes that want to connect to the X server, but that means we
       ;; have to be careful here not to be tricked into thinking those frames
       ;; are on `display'.
       (not (eq (framep frame) t))))

427 428
(defun server-select-display (display)
  ;; If the current frame is on `display' we're all set.
429
  ;; Similarly if we are unable to open frames on other displays, there's
430 431
  ;; nothing more we can do.
  (unless (or (not (fboundp 'make-frame-on-display))
432
              (server--on-display-p (selected-frame) display))
433 434
    ;; Otherwise, look for an existing frame there and select it.
    (dolist (frame (frame-list))
435
      (when (server--on-display-p frame display)
436 437
	(select-frame frame)))
    ;; If there's no frame on that display yet, create and select one.
438
    (unless (server--on-display-p (selected-frame) display)
439 440 441 442 443
      (let* ((buffer (generate-new-buffer " *server-dummy*"))
             (frame (make-frame-on-display
                     display
                     ;; Make it display (and remember) some dummy buffer, so
                     ;; we can detect later if the frame is in use or not.
444
                     `((server-dummy-buffer . ,buffer)
445 446 447 448 449 450 451 452 453 454 455 456 457 458
                       ;; This frame may be deleted later (see
                       ;; server-unselect-display) so we want it to be as
                       ;; unobtrusive as possible.
                       (visibility . nil)))))
        (select-frame frame)
        (set-window-buffer (selected-window) buffer)
        frame))))

(defun server-unselect-display (frame)
  (when (frame-live-p frame)
    ;; If the temporary frame is in use (displays something real), make it
    ;; visible.  If not (which can happen if the user's customizations call
    ;; pop-to-buffer etc.), delete it to avoid preserving the connection after
    ;; the last real frame is deleted.
459 460 461 462

    ;; Rewritten to avoid inadvertently killing the current buffer after
    ;; `delete-frame' removed FRAME (Bug#10729).
    (let ((buffer (frame-parameter frame 'server-dummy-buffer)))
463 464 465 466 467 468 469
      (if (and (one-window-p 'nomini frame)
	       (eq (window-buffer (frame-first-window frame)) buffer))
	  ;; The temp frame still only shows one buffer, and that is the
	  ;; internal temp buffer.
	  (delete-frame frame)
	(set-frame-parameter frame 'visibility t)
	(set-frame-parameter frame 'server-dummy-buffer nil))
470 471
      (when (buffer-live-p buffer)
	(kill-buffer buffer)))))
472

473
(defun server-handle-delete-frame (frame)
474 475
  "Delete the client connection when the emacsclient frame is deleted.
\(To be used from `delete-frame-functions'.)"
Karoly Lorentey's avatar
Karoly Lorentey committed
476
  (let ((proc (frame-parameter frame 'client)))
477 478
    (when (and (frame-live-p frame)
	       proc
479
	       ;; See if this is the last frame for this client.
480
	       (>= 1 (let ((frame-num 0))
481 482 483 484
		       (dolist (f (frame-list))
			 (when (eq proc (frame-parameter f 'client))
			   (setq frame-num (1+ frame-num))))
		       frame-num)))
Karoly Lorentey's avatar
Karoly Lorentey committed
485
      (server-log (format "server-handle-delete-frame, frame %s" frame) proc)
486
      (server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later.
Karoly Lorentey's avatar
Karoly Lorentey committed
487

488
(defun server-handle-suspend-tty (terminal)
489
  "Notify the client process that its tty device is suspended."
490
  (dolist (proc (server-clients-with 'terminal terminal))
491 492 493
    (server-log (format "server-handle-suspend-tty, terminal %s" terminal)
                proc)
    (condition-case nil
494
	(server-send-string proc "-suspend \n")
495 496
      (file-error                       ;The pipe/socket was closed.
       (ignore-errors (server-delete-client proc))))))
497

498
(defun server-unquote-arg (arg)
499 500
  "Remove &-quotation from ARG.
See `server-quote-arg' and `server-process-filter'."
501 502
  (replace-regexp-in-string
   "&." (lambda (s)
503
	  (pcase (aref s 1)
504 505 506
	    (?& "&")
	    (?- "-")
	    (?n "\n")
507
	    (_ " ")))
508
   arg t t))
root's avatar
root committed
509

510
(defun server-quote-arg (arg)
Karoly Lorentey's avatar
Karoly Lorentey committed
511
  "In ARG, insert a & before each &, each space, each newline, and -.
512
Change spaces to underscores, too, so that the return value never
513 514 515
contains a space.

See `server-unquote-arg' and `server-process-filter'."
516 517
  (replace-regexp-in-string
   "[-&\n ]" (lambda (s)
518
	       (pcase (aref s 0)
519 520 521 522 523 524
		 (?& "&&")
		 (?- "&-")
		 (?\n "&n")
		 (?\s "&_")))
   arg t t))

525
(defun server-send-string (proc string)
526
  "A wrapper around `process-send-string' for logging."
527 528 529
  (server-log (concat "Sent " string) proc)
  (process-send-string proc string))

530 531 532 533 534 535 536
(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:
- there's no symlink involved
- it's owned by us
- it's not readable/writable by anybody else."
  (setq dir (directory-file-name dir))
537
  (let ((attrs (file-attributes dir 'integer)))
538
    (unless attrs
539
      (cl-letf (((default-file-modes) ?\700)) (make-directory dir t))
540
      (setq attrs (file-attributes dir 'integer)))
541

542
    ;; Check that it's safe for use.
543 544
    (let* ((uid (nth 2 attrs))
	   (w32 (eq system-type 'windows-nt))
545 546
           (unsafe (cond
                    ((not (eq t (car attrs)))
547 548 549 550
                     (if (null attrs) "its attributes can't be checked"
                       (format "it is a %s"
                               (if (stringp (car attrs))
                                   "symlink" "file"))))
551 552 553 554
                    ((and w32 (zerop uid)) ; on FAT32?
                     (display-warning
                      'server
                      (format-message "\
555
Using `%s' to store Emacs-server authentication files.
556 557
Directories on FAT32 filesystems are NOT secure against tampering.
See variable `server-auth-dir' for details."
558 559 560 561 562 563 564 565 566 567
                                      (file-name-as-directory dir))
                      :warning)
                     nil)
                    ((and (/= uid (user-uid)) ; is the dir ours?
                          (or (not w32)
                              ;; Files created on Windows by Administrator
                              ;; (RID=500) have the Administrators (RID=544)
                              ;; group recorded as the owner.
                              (/= uid 544) (/= (user-uid) 500)))
                     (format "it is not owned by you (owner = %s (%d))"
568
                             (user-full-name uid) uid))
569 570 571 572 573 574
                    (w32 nil)           ; on NTFS?
                    ((/= 0 (logand ?\077 (file-modes dir)))
                     (format "it is accessible by others (%03o)"
                             (file-modes dir)))
                    (t nil))))
      (when unsafe
575 576
        (error "`%s' is not a safe directory because %s"
               (expand-file-name dir) unsafe)))))
577

578
(defun server-generate-key ()
579 580 581
  "Generate and return a random authentication key.
The key is a 64-byte string of random chars in the range `!'..`~'.
If called interactively, also inserts it into current buffer."
582 583
  (interactive)
  (let ((auth-key
584 585 586
	 (cl-loop repeat 64
                  collect (+ 33 (random 94)) into auth
                  finally return (concat auth))))
587
    (if (called-interactively-p 'interactive)
588 589 590 591
	(insert auth-key))
    auth-key))

(defun server-get-auth-key ()
592
  "Return server's authentication key.
593

594 595 596
If `server-auth-key' is nil, just call `server-generate-key'.
Otherwise, if `server-auth-key' is a valid key, return it.
If the key is not valid, signal an error."
597
  (if server-auth-key
598
    (if (string-match-p "^[!-~]\\{64\\}$" server-auth-key)
599
        server-auth-key
600
      (error "The key `%s' is invalid" server-auth-key))
601 602
    (server-generate-key)))

Roland McGrath's avatar
Roland McGrath committed
603
;;;###autoload
604
(defun server-start (&optional leave-dead inhibit-prompt)
root's avatar
root committed
605
  "Allow this Emacs process to be a server for client processes.
606 607 608 609
This starts a server communications subprocess through which client
\"editors\" can send your editing commands to this Emacs job.
To use the server, set up the program `emacsclient' in the Emacs
distribution as your standard \"editor\".
root's avatar
root committed
610

611
Optional argument LEAVE-DEAD (interactively, a prefix arg) means just
612 613
kill any existing server communications subprocess.

614 615 616 617
If a server is already running, restart it.  If clients are
running, ask the user for confirmation first, unless optional
argument INHIBIT-PROMPT is non-nil.

618 619
To force-start a server, do \\[server-force-delete] and then
\\[server-start]."
root's avatar
root committed
620
  (interactive "P")
621 622 623 624
  (when (or (not server-clients)
	    ;; Ask the user before deleting existing clients---except
	    ;; when we can't get user input, which may happen when
	    ;; doing emacsclient --eval "(kill-emacs)" in daemon mode.
625 626 627 628 629 630 631 632
	    (cond
	     ((and (daemonp)
		   (null (cdr (frame-list)))
		   (eq (selected-frame) terminal-frame))
	      leave-dead)
	     (inhibit-prompt t)
	     (t (yes-or-no-p
		 "The current server still has clients; delete them? "))))
633 634 635 636 637
    (let* ((server-dir (if server-use-tcp server-auth-dir server-socket-dir))
	   (server-file (expand-file-name server-name server-dir)))
      (when server-process
	;; kill it dead!
	(ignore-errors (delete-process server-process)))
638
      ;; Check to see if an uninitialized external socket has been
639 640
      ;; passed in, if that is the case, skip checking
      ;; `server-running-p' as this will return the wrong result.
641
      (if (and internal--daemon-sockname
642 643
               (not server--external-socket-initialized))
          (setq server--external-socket-initialized t)
644 645
        ;; Delete the socket files made by previous server invocations.
        (if (not (eq t (server-running-p server-name)))
646
           ;; Remove any leftover socket or authentication file.
647 648 649 650 651 652 653 654 655 656 657
           (ignore-errors
             (let (delete-by-moving-to-trash)
               (delete-file server-file)))
         (setq server-mode nil) ;; already set by the minor mode code
         (display-warning
          'server
          (concat "Unable to start the Emacs server.\n"
                  (format "There is an existing Emacs server, named %S.\n"
                          server-name)
                  (substitute-command-keys
                    "To start the server in this Emacs process, stop the existing
658
server or call `\\[server-force-delete]' to forcibly disconnect it."))
659 660
          :warning)
         (setq leave-dead t)))
661 662 663 664 665 666
      ;; If this Emacs already had a server, clear out associated status.
      (while server-clients
	(server-delete-client (car server-clients)))
      ;; Now any previous server is properly stopped.
      (if leave-dead
	  (progn
667
	    (unless (eq t leave-dead) (server-log (message "Server stopped")))
668
	    (setq server-process nil))
669 670 671 672
	;; Make sure there is a safe directory in which to place the socket.
	(server-ensure-safe-dir server-dir)
	(when server-process
	  (server-log (message "Restarting server")))
673
	(cl-letf (((default-file-modes) ?\700))
674
	  (add-hook 'suspend-tty-functions 'server-handle-suspend-tty)
675
	  (add-hook 'delete-frame-functions 'server-handle-delete-frame)
676 677
	  (add-hook 'kill-emacs-query-functions
                    'server-kill-emacs-query-function)
678 679 680 681 682 683
          ;; We put server's kill-emacs-hook after the others, so that
          ;; frames are not deleted too early, because doing that
          ;; would severely degrade our abilities to communicate with
          ;; the user, while some hooks may wish to ask the user
          ;; questions (e.g., desktop-kill).
	  (add-hook 'kill-emacs-hook 'server-force-stop t) ;Cleanup upon exit.
684 685 686 687 688
	  (setq server-process
		(apply #'make-network-process
		       :name server-name
		       :server t
		       :noquery t
689 690
		       :sentinel #'server-sentinel
		       :filter #'server-process-filter
691
		       :use-external-socket t
692 693
		       ;; We must receive file names without being decoded.
		       ;; Those are decoded by server-process-filter according
694 695 696
		       ;; to file-name-coding-system.  Also don't get
		       ;; confused by CRs since we don't quote them.
		       :coding 'raw-text-unix
Stefan Monnier's avatar
Stefan Monnier committed
697
		       ;; The other args depend on the kind of socket used.
698
		       (if server-use-tcp
699
			   (list :family 'ipv4  ;; We're not ready for IPv6 yet
700
				 :service (or server-port t)
701
				 :host (or server-host 'local)
702 703 704 705 706
				 :plist '(:authenticated nil))
			 (list :family 'local
			       :service server-file
			       :plist '(:authenticated t)))))
	  (unless server-process (error "Could not start server process"))
707
	  (process-put server-process :server-file server-file)
708
	  (when server-use-tcp
709
	    (let ((auth-key (server-get-auth-key)))
710 711 712 713 714 715
	      (process-put server-process :auth-key auth-key)
	      (with-temp-file server-file
		(set-buffer-multibyte nil)
		(setq buffer-file-coding-system 'no-conversion)
		(insert (format-network-address
			 (process-contact server-process :local))
716
			" " (number-to-string (emacs-pid)) ; Kept for compatibility
717
			"\n" auth-key)))))))))
Dave Love's avatar
Dave Love committed
718

719 720 721
(defun server-force-stop ()
  "Kill all connections to the current server.
This function is meant to be called from `kill-emacs-hook'."
722
  (server-start t t))
723

724 725 726 727 728 729 730 731 732 733 734 735 736 737
;;;###autoload
(defun server-force-delete (&optional name)
  "Unconditionally delete connection file for server NAME.
If server is running, it is first stopped.
NAME defaults to `server-name'.  With argument, ask for NAME."
  (interactive
   (list (if current-prefix-arg
	     (read-string "Server name: " nil nil server-name))))
  (when server-mode (with-temp-message nil (server-mode -1)))
  (let ((file (expand-file-name (or name server-name)
				(if server-use-tcp
				    server-auth-dir
				  server-socket-dir))))
    (condition-case nil
738
	(let (delete-by-moving-to-trash)
739 740 741 742 743
	  (delete-file file)
	  (message "Connection file %S deleted" file))
      (file-error
       (message "No connection file %S" file)))))

744
(defun server-running-p (&optional name)
745 746 747 748 749 750 751
  "Test whether server NAME is running.

Return values:
  nil              the server is definitely not running.
  t                the server seems to be running.
  something else   we cannot determine whether it's running without using
                   commands which may have to wait for a long time."
752 753
  (unless name (setq name server-name))
  (condition-case nil
754 755 756
      (if server-use-tcp
	  (with-temp-buffer
	    (insert-file-contents-literally (expand-file-name name server-auth-dir))
757
	    (or (and (looking-at "127\\.0\\.0\\.1:[0-9]+ \\([0-9]+\\)")
758
		     (assq 'comm
759
			   (process-attributes
760 761 762
			    (string-to-number (match-string 1))))
		     t)
		:other))
763 764 765 766 767 768 769
	(delete-process
	 (make-network-process
	  :name "server-client-test" :family 'local :server nil :noquery t
	  :service (expand-file-name name server-socket-dir)))
	t)
    (file-error nil)))

Dave Love's avatar
Dave Love committed
770 771 772
;;;###autoload
(define-minor-mode server-mode
  "Toggle Server mode.
773 774 775 776
With a prefix argument ARG, enable Server mode if ARG is
positive, and disable it otherwise.  If called from Lisp, enable
Server mode if ARG is omitted or nil.

Dave Love's avatar
Dave Love committed
777
Server mode runs a process that accepts commands from the
778 779
`emacsclient' program.  See Info node `Emacs server' and
`server-start' for details."
Dave Love's avatar
Dave Love committed
780 781
  :global t
  :group 'server
782
  :version "22.1"
Dave Love's avatar
Dave Love committed
783 784 785
  ;; 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)))
root's avatar
root committed
786

787 788
(defun server-eval-and-print (expr proc)
  "Eval EXPR and send the result back to client PROC."
789 790 791 792 793 794 795 796
  ;; While we're running asynchronously (from a process filter), it is likely
  ;; that the emacsclient command was run in response to a user
  ;; action, so the user probably knows that Emacs is processing this
  ;; emacsclient request, so if we get a C-g it's likely that the user
  ;; intended it to interrupt us rather than interrupt whatever Emacs
  ;; was doing before it started handling the process filter.
  ;; Hence `with-local-quit' (bug#6585).
  (let ((v (with-local-quit (eval (car (read-from-string expr))))))
797
    (when proc
798 799 800 801 802
      (with-temp-buffer
        (let ((standard-output (current-buffer)))
          (pp v)
          (let ((text (buffer-substring-no-properties
                       (point-min) (point-max))))
803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818
            (server-reply-print (server-quote-arg text) proc)))))))

(defconst server-msg-size 1024
  "Maximum size of a message sent to a client.")

(defun server-reply-print (qtext proc)
  "Send a `-print QTEXT' command to client PROC.
QTEXT must be already quoted.
This handles splitting the command if it would be bigger than
`server-msg-size'."
  (let ((prefix "-print ")
	part)
    (while (> (+ (length qtext) (length prefix) 1) server-msg-size)
      ;; We have to split the string
      (setq part (substring qtext 0 (- server-msg-size (length prefix) 1)))
      ;; Don't split in the middle of a quote sequence
819
      (if (string-match "\\(^\\|[^&]\\)&\\(&&\\)*$" part)
820 821 822 823 824 825
	  ;; There is an uneven number of & at the end
	  (setq part (substring part 0 -1)))
      (setq qtext (substring qtext (length part)))
      (server-send-string proc (concat prefix part "\n"))
      (setq prefix "-print-nonl "))
    (server-send-string proc (concat prefix qtext "\n"))))
826 827

(defun server-create-tty-frame (tty type proc)
828 829 830 831
  (unless tty
    (error "Invalid terminal device"))
  (unless type
    (error "Invalid terminal type"))
832
  (add-to-list 'frame-inherited-parameters 'client)
833
  (let ((frame
834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860
         (server-with-environment
             (process-get proc 'env)
             '("LANG" "LC_CTYPE" "LC_ALL"
               ;; For tgetent(3); list according to ncurses(3).
               "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES"
               "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING"
               "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO"
               "TERMINFO_DIRS" "TERMPATH"
               ;; rxvt wants these
               "COLORFGBG" "COLORTERM")
           (make-frame `((window-system . nil)
                         (tty . ,tty)
                         (tty-type . ,type)
                         ;; Ignore nowait here; we always need to
                         ;; clean up opened ttys when the client dies.
                         (client . ,proc)
                         ;; This is a leftover from an earlier
                         ;; attempt at making it possible for process
                         ;; run in the server process to use the
                         ;; environment of the client process.
                         ;; It has no effect now and to make it work
                         ;; we'd need to decide how to make
                         ;; process-environment interact with client
                         ;; envvars, and then to change the
                         ;; C functions `child_setup' and
                         ;; `getenv_internal' accordingly.
                         (environment . ,(process-get proc 'env)))))))
861

862 863 864 865
    ;; ttys don't use the `display' parameter, but callproc.c does to set
    ;; the DISPLAY environment on subprocesses.
    (set-frame-parameter frame 'display
                         (getenv-internal "DISPLAY" (process-get proc 'env)))
866
    (select-frame frame)
867 868
    (process-put proc 'frame frame)
    (process-put proc 'terminal (frame-terminal frame))
869 870
    frame))

871 872
(defun server-create-window-system-frame (display nowait proc parent-id
						  &optional parameters)
873 874 875 876 877 878
  (let* ((display (or display
                      (frame-parameter nil 'display)
                      (error "Please specify display.")))
         (w (or (cdr (assq 'window-system parameters))
                (window-system-for-display display))))

879 880 881 882 883 884
    ;; Special case for ns.  This is because DISPLAY may not be set at all
    ;; which in the ns case isn't an error.  The variable display then becomes
    ;; the fully qualified hostname, which make-frame-on-display below
    ;; does not understand and throws an error.
    ;; It may also be a valid X display, but if Emacs is compiled for ns, it
    ;; can not make X frames.
885
    (if (featurep 'ns-win)
886 887 888 889 890 891
	(setq w 'ns display "ns")
      ;; FIXME! Not sure what this was for, and not sure how it should work
      ;; in the cl-defmethod new world!
      ;;(unless (assq w window-system-initialization-alist)
      ;;  (setq w nil))
      )
892

893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917
    (cond (w
           ;; Flag frame as client-created, but use a dummy client.
           ;; This will prevent the frame from being deleted when
           ;; emacsclient quits while also preventing
           ;; `server-save-buffers-kill-terminal' from unexpectedly
           ;; killing emacs on that frame.
           (let* ((params `((client . ,(if nowait 'nowait proc))
                            ;; This is a leftover, see above.
                            (environment . ,(process-get proc 'env))
                            ,@parameters))
                  frame)
             (if parent-id
                 (push (cons 'parent-id (string-to-number parent-id)) params))
             (add-to-list 'frame-inherited-parameters 'client)
             (setq frame (make-frame-on-display display params))
             (server-log (format "%s created" frame) proc)
             (select-frame frame)
             (process-put proc 'frame frame)
             (process-put proc 'terminal (frame-terminal frame))
             frame))

          (t
           (server-log "Window system unsupported" proc)
           (server-send-string proc "-window-system-unsupported \n")
           nil))))
918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934

(defun server-goto-toplevel (proc)
  (condition-case nil
      ;; If we're running isearch, we must abort it to allow Emacs to
      ;; display the buffer and switch to it.
      (dolist (buffer (buffer-list))
        (with-current-buffer buffer
          (when (bound-and-true-p isearch-mode)
            (isearch-cancel))))
    ;; Signaled by isearch-cancel.
    (quit (message nil)))
  (when (> (recursion-depth) 0)
    ;; We're inside a minibuffer already, so if the emacs-client is trying
    ;; to open a frame on a new display, we might end up with an unusable
    ;; frame because input from that display will be blocked (until exiting
    ;; the minibuffer).  Better exit this minibuffer right away.
    ;; Similarly with recursive-edits such as the splash screen.
935
    (run-with-timer 0 nil (lambda () (server-execute-continuation proc)))
936 937 938 939 940 941 942 943 944 945 946 947 948 949
    (top-level)))

;; We use various special properties on process objects:
;; - `env' stores the info about the environment of the emacsclient process.
;; - `continuation' is a no-arg function that we need to execute.  It contains
;;   commands we wanted to execute in some earlier invocation of the process
;;   filter but that we somehow were unable to process at that time
;;   (e.g. because we first need to throw to the toplevel).

(defun server-execute-continuation (proc)
  (let ((continuation (process-get proc 'continuation)))
    (process-put proc 'continuation nil)
    (if continuation (ignore-errors (funcall continuation)))))

950
(cl-defun server-process-filter (proc string)
Dave Love's avatar
Dave Love committed
951
  "Process a request from the server to edit some files.
952
PROC is the server process.  STRING consists of a sequence of
953 954 955
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.
956 957 958 959 960

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):

961 962
	-env HOME=/home/lorentey
	-env DISPLAY=:0.0
963 964 965 966 967 968
	... lots of other -env commands
	-display :0.0
	-window-system

The following commands are accepted by the server:

969 970
`-auth AUTH-STRING'
  Authenticate the client using the secret authentication string
971
  AUTH-STRING.
972

973
`-env NAME=VALUE'
974 975
  An environment variable on the client side.

976 977 978
`-dir DIRNAME'
  The current working directory of the client process.

979 980