server.el 66.3 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-2016 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 <http://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

(defcustom server-done-hook nil
192
  "Hook run when done editing a buffer for the Emacs server."
Richard M. Stallman's avatar
Richard M. Stallman committed
193
  :group 'server
194
  :type 'hook)
195

196 197
(defvar server-process nil
  "The current server process.")
root's avatar
root committed
198 199 200

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

root's avatar
root committed
203
(defvar server-buffer-clients nil
204
  "List of client processes requesting editing of current buffer.")
205
(make-variable-buffer-local 'server-buffer-clients)
root's avatar
root committed
206 207 208
;; Changing major modes should not erase this local.
(put 'server-buffer-clients 'permanent-local t)

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

Richard M. Stallman's avatar
Richard M. Stallman committed
229
(defcustom server-temp-file-regexp "^/tmp/Re\\|/draft$"
230
  "Regexp matching names of temporary files.
Dave Love's avatar
Dave Love committed
231 232
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
233 234
  :group 'server
  :type 'regexp)
root's avatar
root committed
235

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

Glenn Morris's avatar
Glenn Morris committed
248
;; FIXME? This is not a minor mode; what's the point of this?  (See bug#20201)
root's avatar
root committed
249
(or (assq 'server-buffer-clients minor-mode-alist)
250
    (push '(server-buffer-clients " Server") minor-mode-alist))
root's avatar
root committed
251

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

258
;;;###autoload
259 260 261 262 263 264 265
(defcustom server-name "server"
  "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
266

Chong Yidong's avatar
Chong Yidong committed
267 268
;; We do not use `temporary-file-directory' here, because emacsclient
;; does not read the init file.
269
(defvar server-socket-dir
270 271 272 273
  (and (featurep 'make-network-process '(:family local))
       (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid)))
  "The directory in which to place the server socket.
If local sockets are not supported, this is nil.")
274

Karoly Lorentey's avatar
Karoly Lorentey committed
275 276 277
(defun server-clients-with (property value)
  "Return a list of clients with PROPERTY set to VALUE."
  (let (result)
278
    (dolist (proc server-clients)
279
      (when (equal value (process-get proc property))
280 281
	(push proc result)))
    result))
Karoly Lorentey's avatar
Karoly Lorentey committed
282 283 284 285

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

288 289
(defmacro server-with-environment (env vars &rest body)
  "Evaluate BODY with environment variables VARS set to those in ENV.
290 291
The environment variables are then restored to their previous values.

292 293
VARS should be a list of strings.
ENV should be in the same format as `process-environment'."
294
  (declare (indent 2))
295 296 297
  (let ((var (make-symbol "var"))
	(value (make-symbol "value")))
    `(let ((process-environment process-environment))
298
       (dolist (,var ,vars)
299
         (let ((,value (getenv-internal ,var ,env)))
300 301 302
           (push (if (stringp ,value)
                     (concat ,var "=" ,value)
                   ,var)
303 304
                 process-environment)))
       (progn ,@body))))
305

306
(defun server-delete-client (proc &optional noframe)
307
  "Delete PROC, including its buffers, terminals and frames.
308 309
If NOFRAME is non-nil, let the frames live.
Updates `server-clients'."
310
  (server-log (concat "server-delete-client" (if noframe " noframe")) proc)
Karoly Lorentey's avatar
Karoly Lorentey committed
311
  ;; Force a new lookup of client (prevents infinite recursion).
312 313
  (when (memq proc server-clients)
    (let ((buffers (process-get proc 'buffers)))
Karoly Lorentey's avatar
Karoly Lorentey committed
314

315
      ;; Kill the client's buffers.
Karoly Lorentey's avatar
Karoly Lorentey committed
316
      (dolist (buf buffers)
317 318 319
	(when (buffer-live-p buf)
	  (with-current-buffer buf
	    ;; Kill the buffer if necessary.
320 321
	    (when (and (equal server-buffer-clients
			      (list proc))
322 323
		       (or (and server-kill-new-buffers
				(not server-existing-buffer))
324 325 326 327 328 329 330 331 332 333
			   (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
334

335 336 337 338 339 340 341 342 343 344
      ;; 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))))

345
      (setq server-clients (delq proc server-clients))
346

347 348 349 350 351 352 353
      ;; 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
354 355

      ;; Delete the client's process.
356 357
      (if (eq (process-status proc) 'open)
	  (delete-process proc))
Karoly Lorentey's avatar
Karoly Lorentey committed
358 359 360

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

361
(defvar server-log-time-function 'current-time-string
362
  "Function to generate timestamps for `server-buffer'.")
363

Stefan Monnier's avatar
Stefan Monnier committed
364 365
(defconst server-buffer " *server*"
  "Buffer used internally by Emacs's server.
366
One use is to log the I/O for debugging purposes (see option `server-log'),
Stefan Monnier's avatar
Stefan Monnier committed
367
the other is to provide a current buffer in which the process filter can
368
safely let-bind buffer-local variables like `default-directory'.")
Stefan Monnier's avatar
Stefan Monnier committed
369 370 371 372

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

373
(defun server-log (string &optional client)
374
  "If option `server-log' is non-nil, log STRING to `server-buffer'.
375
If CLIENT is non-nil, add a description of it to the logged message."
Stefan Monnier's avatar
Stefan Monnier committed
376 377
  (when server-log
    (with-current-buffer (get-buffer-create server-buffer)
378
      (goto-char (point-max))
379
      (insert (funcall server-log-time-function)
380
	      (cond
381 382 383
	       ((null client) " ")
	       ((listp client) (format " %s: " (car client)))
	       (t (format " %s: " client)))
384 385
	      string)
      (or (bolp) (newline)))))
root's avatar
root committed
386 387

(defun server-sentinel (proc msg)
Karoly Lorentey's avatar
Karoly Lorentey committed
388
  "The process sentinel for Emacs server connections."
389 390 391 392 393
  ;; 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))
394
  ;; Delete the associated connection file, if applicable.
395 396 397 398 399
  ;; 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)
400
       (ignore-errors
401
	 (delete-file (process-get proc :server-file))))
Karoly Lorentey's avatar
Karoly Lorentey committed
402 403
  (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
  (server-delete-client proc))
404

405 406 407 408 409 410 411 412 413
(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))))

414 415
(defun server-select-display (display)
  ;; If the current frame is on `display' we're all set.
416
  ;; Similarly if we are unable to open frames on other displays, there's
417 418
  ;; nothing more we can do.
  (unless (or (not (fboundp 'make-frame-on-display))
419
              (server--on-display-p (selected-frame) display))
420 421
    ;; Otherwise, look for an existing frame there and select it.
    (dolist (frame (frame-list))
422
      (when (server--on-display-p frame display)
423 424
	(select-frame frame)))
    ;; If there's no frame on that display yet, create and select one.
425
    (unless (server--on-display-p (selected-frame) display)
426 427 428 429 430
      (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.
431
                     `((server-dummy-buffer . ,buffer)
432 433 434 435 436 437 438 439 440 441 442 443 444 445
                       ;; 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.
446 447 448 449

    ;; Rewritten to avoid inadvertently killing the current buffer after
    ;; `delete-frame' removed FRAME (Bug#10729).
    (let ((buffer (frame-parameter frame 'server-dummy-buffer)))
450 451 452 453 454 455 456
      (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))
457 458
      (when (buffer-live-p buffer)
	(kill-buffer buffer)))))
459

460
(defun server-handle-delete-frame (frame)
461 462
  "Delete the client connection when the emacsclient frame is deleted.
\(To be used from `delete-frame-functions'.)"
Karoly Lorentey's avatar
Karoly Lorentey committed
463
  (let ((proc (frame-parameter frame 'client)))
464 465
    (when (and (frame-live-p frame)
	       proc
466
	       ;; See if this is the last frame for this client.
467
	       (>= 1 (let ((frame-num 0))
468 469 470 471
		       (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
472
      (server-log (format "server-handle-delete-frame, frame %s" frame) proc)
473
      (server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later.
Karoly Lorentey's avatar
Karoly Lorentey committed
474

475
(defun server-handle-suspend-tty (terminal)
476
  "Notify the client process that its tty device is suspended."
477
  (dolist (proc (server-clients-with 'terminal terminal))
478 479 480
    (server-log (format "server-handle-suspend-tty, terminal %s" terminal)
                proc)
    (condition-case nil
481
	(server-send-string proc "-suspend \n")
482 483
      (file-error                       ;The pipe/socket was closed.
       (ignore-errors (server-delete-client proc))))))
484

485
(defun server-unquote-arg (arg)
486 487
  "Remove &-quotation from ARG.
See `server-quote-arg' and `server-process-filter'."
488 489
  (replace-regexp-in-string
   "&." (lambda (s)
490
	  (pcase (aref s 1)
491 492 493
	    (?& "&")
	    (?- "-")
	    (?n "\n")
494
	    (_ " ")))
495
   arg t t))
root's avatar
root committed
496

497
(defun server-quote-arg (arg)
Karoly Lorentey's avatar
Karoly Lorentey committed
498
  "In ARG, insert a & before each &, each space, each newline, and -.
499
Change spaces to underscores, too, so that the return value never
500 501 502
contains a space.

See `server-unquote-arg' and `server-process-filter'."
503 504
  (replace-regexp-in-string
   "[-&\n ]" (lambda (s)
505
	       (pcase (aref s 0)
506 507 508 509 510 511
		 (?& "&&")
		 (?- "&-")
		 (?\n "&n")
		 (?\s "&_")))
   arg t t))

512
(defun server-send-string (proc string)
513
  "A wrapper around `process-send-string' for logging."
514 515 516
  (server-log (concat "Sent " string) proc)
  (process-send-string proc string))

517 518 519 520 521 522 523
(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))
524
  (let ((attrs (file-attributes dir 'integer)))
525
    (unless attrs
526
      (cl-letf (((default-file-modes) ?\700)) (make-directory dir t))
527
      (setq attrs (file-attributes dir 'integer)))
528

529
    ;; Check that it's safe for use.
530 531
    (let* ((uid (nth 2 attrs))
	   (w32 (eq system-type 'windows-nt))
532 533 534 535 536
	   (safe (cond
		  ((not (eq t (car attrs))) nil)  ; is a dir?
		  ((and w32 (zerop uid))	  ; on FAT32?
		   (display-warning
		    'server
537 538
		    (format-message "\
Using `%s' to store Emacs-server authentication files.
539 540
Directories on FAT32 filesystems are NOT secure against tampering.
See variable `server-auth-dir' for details."
541 542 543 544 545 546 547 548 549 550 551 552 553
			    (file-name-as-directory dir))
		    :warning)
		   t)
		  ((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)))
		   nil)
		  (w32 t)			  ; on NTFS?
		  (t				  ; else, check permissions
		   (zerop (logand ?\077 (file-modes dir)))))))
554 555
      (unless safe
	(error "The directory `%s' is unsafe" dir)))))
556

557
(defun server-generate-key ()
558 559 560
  "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."
561 562
  (interactive)
  (let ((auth-key
563 564 565
	 (cl-loop repeat 64
                  collect (+ 33 (random 94)) into auth
                  finally return (concat auth))))
566
    (if (called-interactively-p 'interactive)
567 568 569 570
	(insert auth-key))
    auth-key))

(defun server-get-auth-key ()
571
  "Return server's authentication key.
572

573 574 575
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."
576
  (if server-auth-key
577
    (if (string-match-p "^[!-~]\\{64\\}$" server-auth-key)
578
        server-auth-key
579
      (error "The key `%s' is invalid" server-auth-key))
580 581
    (server-generate-key)))

Roland McGrath's avatar
Roland McGrath committed
582
;;;###autoload
583
(defun server-start (&optional leave-dead inhibit-prompt)
root's avatar
root committed
584
  "Allow this Emacs process to be a server for client processes.
585 586 587 588
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
589

590
Optional argument LEAVE-DEAD (interactively, a prefix arg) means just
591 592
kill any existing server communications subprocess.

593 594 595 596
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.

597 598
To force-start a server, do \\[server-force-delete] and then
\\[server-start]."
root's avatar
root committed
599
  (interactive "P")
600 601 602 603
  (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.
604 605 606 607 608 609 610 611
	    (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? "))))
612 613 614 615 616 617 618 619
    (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)))
      ;; Delete the socket files made by previous server invocations.
      (if (not (eq t (server-running-p server-name)))
	  ;; Remove any leftover socket or authentication file
620
	  (ignore-errors
621 622
	    (let (delete-by-moving-to-trash)
	      (delete-file server-file)))
623
	(setq server-mode nil) ;; already set by the minor mode code
624 625 626 627 628
	(display-warning
	 'server
	 (concat "Unable to start the Emacs server.\n"
		 (format "There is an existing Emacs server, named %S.\n"
			 server-name)
629 630 631
		 (substitute-command-keys
                  "To start the server in this Emacs process, stop the existing
server or call `\\[server-force-delete]' to forcibly disconnect it."))
632
	 :warning)
633
	(setq leave-dead t))
634 635 636 637 638 639
      ;; 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
640
	    (unless (eq t leave-dead) (server-log (message "Server stopped")))
641
	    (setq server-process nil))
642 643 644 645
	;; 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")))
646
	(cl-letf (((default-file-modes) ?\700))
647
	  (add-hook 'suspend-tty-functions 'server-handle-suspend-tty)
648
	  (add-hook 'delete-frame-functions 'server-handle-delete-frame)
649 650
	  (add-hook 'kill-emacs-query-functions
                    'server-kill-emacs-query-function)
651 652 653 654 655 656
          ;; 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.
657 658 659 660 661
	  (setq server-process
		(apply #'make-network-process
		       :name server-name
		       :server t
		       :noquery t
662 663
		       :sentinel #'server-sentinel
		       :filter #'server-process-filter
664
		       :use-external-socket t
665 666
		       ;; We must receive file names without being decoded.
		       ;; Those are decoded by server-process-filter according
667 668 669
		       ;; 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
670
		       ;; The other args depend on the kind of socket used.
671
		       (if server-use-tcp
672
			   (list :family 'ipv4  ;; We're not ready for IPv6 yet
673
				 :service (or server-port t)
674
				 :host (or server-host 'local)
675 676 677 678 679
				 :plist '(:authenticated nil))
			 (list :family 'local
			       :service server-file
			       :plist '(:authenticated t)))))
	  (unless server-process (error "Could not start server process"))
680
	  (process-put server-process :server-file server-file)
681
	  (when server-use-tcp
682
	    (let ((auth-key (server-get-auth-key)))
683 684 685 686 687 688
	      (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))
689
			" " (number-to-string (emacs-pid)) ; Kept for compatibility
690
			"\n" auth-key)))))))))
Dave Love's avatar
Dave Love committed
691

692 693 694
(defun server-force-stop ()
  "Kill all connections to the current server.
This function is meant to be called from `kill-emacs-hook'."
695
  (server-start t t))
696

697 698 699 700 701 702 703 704 705 706 707 708 709 710
;;;###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
711
	(let (delete-by-moving-to-trash)
712 713 714 715 716
	  (delete-file file)
	  (message "Connection file %S deleted" file))
      (file-error
       (message "No connection file %S" file)))))

717
(defun server-running-p (&optional name)
718 719 720 721 722 723 724
  "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."
725 726
  (unless name (setq name server-name))
  (condition-case nil
727 728 729
      (if server-use-tcp
	  (with-temp-buffer
	    (insert-file-contents-literally (expand-file-name name server-auth-dir))
730
	    (or (and (looking-at "127\\.0\\.0\\.1:[0-9]+ \\([0-9]+\\)")
731
		     (assq 'comm
732
			   (process-attributes
733 734 735
			    (string-to-number (match-string 1))))
		     t)
		:other))
736 737 738 739 740 741 742
	(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
743 744 745
;;;###autoload
(define-minor-mode server-mode
  "Toggle Server mode.
746 747 748 749
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
750
Server mode runs a process that accepts commands from the
751 752
`emacsclient' program.  See Info node `Emacs server' and
`server-start' for details."
Dave Love's avatar
Dave Love committed
753 754
  :global t
  :group 'server
755
  :version "22.1"
Dave Love's avatar
Dave Love committed
756 757 758
  ;; 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
759

760 761
(defun server-eval-and-print (expr proc)
  "Eval EXPR and send the result back to client PROC."
762 763 764 765 766 767 768 769
  ;; 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))))))
770
    (when proc
771 772 773 774 775
      (with-temp-buffer
        (let ((standard-output (current-buffer)))
          (pp v)
          (let ((text (buffer-substring-no-properties
                       (point-min) (point-max))))
776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791
            (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
792
      (if (string-match "\\(^\\|[^&]\\)&\\(&&\\)*$" part)
793 794 795 796 797 798
	  ;; 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"))))
799 800

(defun server-create-tty-frame (tty type proc)
801 802 803 804
  (unless tty
    (error "Invalid terminal device"))
  (unless type
    (error "Invalid terminal type"))
805
  (add-to-list 'frame-inherited-parameters 'client)
806
  (let ((frame
807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833
         (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)))))))
834

835 836 837 838
    ;; 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)))
839
    (select-frame frame)
840 841
    (process-put proc 'frame frame)
    (process-put proc 'terminal (frame-terminal frame))
842 843
    frame))

844 845
(defun server-create-window-system-frame (display nowait proc parent-id
						  &optional parameters)
846 847 848 849 850 851
  (let* ((display (or display
                      (frame-parameter nil 'display)
                      (error "Please specify display.")))
         (w (or (cdr (assq 'window-system parameters))
                (window-system-for-display display))))

852 853 854 855 856 857
    ;; 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.
858
    (if (featurep 'ns-win)
859 860 861 862 863 864
	(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))
      )
865

866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890
    (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))))
891 892 893 894 895 896 897 898 899 900 901 902 903