;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defgroup server nil
"Emacs running as a server process."
;;;###autoload
(put 'server-auth-dir 'risky-local-variable t)
+(defcustom server-auth-key nil
+ "Server authentication key.
+
+Normally, the authentication key is randomly generated when the
+server starts, which guarantees some level of security. 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).
+
+In some situations however, it can be difficult to share randomly
+generated passwords with remote hosts (eg. no shared directory),
+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).
+
+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 authentication
+key."
+ :group 'server
+ :type '(choice
+ (const :tag "Random" nil)
+ (string :tag "Password"))
+ :version "24.3")
+
(defcustom server-raise-frame t
"If non-nil, raise frame when switching to a buffer."
:group 'server
(server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
(server-delete-client proc))
+(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))))
+
(defun server-select-display (display)
;; If the current frame is on `display' we're all set.
;; Similarly if we are unable to open frames on other displays, there's
;; nothing more we can do.
(unless (or (not (fboundp 'make-frame-on-display))
- (equal (frame-parameter (selected-frame) 'display) display))
+ (server--on-display-p (selected-frame) display))
;; Otherwise, look for an existing frame there and select it.
(dolist (frame (frame-list))
- (when (equal (frame-parameter frame 'display) display)
+ (when (server--on-display-p frame display)
(select-frame frame)))
;; If there's no frame on that display yet, create and select one.
- (unless (equal (frame-parameter (selected-frame) 'display) display)
+ (unless (server--on-display-p (selected-frame) display)
(let* ((buffer (generate-new-buffer " *server-dummy*"))
(frame (make-frame-on-display
display
See `server-quote-arg' and `server-process-filter'."
(replace-regexp-in-string
"&." (lambda (s)
- (case (aref s 1)
+ (pcase (aref s 1)
(?& "&")
(?- "-")
(?n "\n")
- (t " ")))
+ (_ " ")))
arg t t))
(defun server-quote-arg (arg)
See `server-unquote-arg' and `server-process-filter'."
(replace-regexp-in-string
"[-&\n ]" (lambda (s)
- (case (aref s 0)
+ (pcase (aref s 0)
(?& "&&")
(?- "&-")
(?\n "&n")
(setq dir (directory-file-name dir))
(let ((attrs (file-attributes dir 'integer)))
(unless attrs
- (letf (((default-file-modes) ?\700)) (make-directory dir t))
+ (cl-letf (((default-file-modes) ?\700)) (make-directory dir t))
(setq attrs (file-attributes dir 'integer)))
;; Check that it's safe for use.
(let* ((uid (nth 2 attrs))
(w32 (eq system-type 'windows-nt))
- (safe (catch :safe
- (unless (eq t (car attrs)) ; is a dir?
- (throw :safe nil))
- (when (and w32 (zerop uid)) ; on FAT32?
- (display-warning
- 'server
- (format "Using `%s' to store Emacs-server authentication files.
+ (safe (cond
+ ((not (eq t (car attrs))) nil) ; is a dir?
+ ((and w32 (zerop uid)) ; on FAT32?
+ (display-warning
+ 'server
+ (format "Using `%s' to store Emacs-server authentication files.
Directories on FAT32 filesystems are NOT secure against tampering.
See variable `server-auth-dir' for details."
- (file-name-as-directory dir))
- :warning)
- (throw :safe t))
- (unless (or (= uid (user-uid)) ; is the dir ours?
- (and w32
- ;; Files created on Windows by
- ;; Administrator (RID=500) have
- ;; the Administrators (RID=544)
- ;; group recorded as the owner.
- (= uid 544) (= (user-uid) 500)))
- (throw :safe nil))
- (when w32 ; on NTFS?
- (throw :safe t))
- (unless (zerop (logand ?\077 (file-modes dir)))
- (throw :safe nil))
- t)))
+ (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)))))))
(unless safe
(error "The directory `%s' is unsafe" dir)))))
+(defun server-generate-key ()
+ "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."
+ (interactive)
+ (let ((auth-key
+ (cl-loop repeat 64
+ collect (+ 33 (random 94)) into auth
+ finally return (concat auth))))
+ (if (called-interactively-p 'interactive)
+ (insert auth-key))
+ auth-key))
+
+(defun server-get-auth-key ()
+ "Return server's authentication key.
+
+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."
+ (if server-auth-key
+ (if (string-match-p "^[!-~]\\{64\\}$" server-auth-key)
+ server-auth-key
+ (error "The key '%s' is invalid" server-auth-key))
+ (server-generate-key)))
+
;;;###autoload
(defun server-start (&optional leave-dead inhibit-prompt)
"Allow this Emacs process to be a server for client processes.
-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\".
+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\".
Optional argument LEAVE-DEAD (interactively, a prefix arg) means just
kill any existing server communications subprocess.
(server-ensure-safe-dir server-dir)
(when server-process
(server-log (message "Restarting server")))
- (letf (((default-file-modes) ?\700))
+ (cl-letf (((default-file-modes) ?\700))
(add-hook 'suspend-tty-functions 'server-handle-suspend-tty)
(add-hook 'delete-frame-functions 'server-handle-delete-frame)
- (add-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function)
- (add-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function)
+ (add-hook 'kill-buffer-query-functions
+ 'server-kill-buffer-query-function)
+ (add-hook 'kill-emacs-query-functions
+ 'server-kill-emacs-query-function)
(add-hook 'kill-emacs-hook 'server-force-stop) ;Cleanup upon exit.
(setq server-process
(apply #'make-network-process
(unless server-process (error "Could not start server process"))
(process-put server-process :server-file server-file)
(when server-use-tcp
- (let ((auth-key
- (loop
- ;; The auth key is a 64-byte string of random chars in the
- ;; range `!'..`~'.
- repeat 64
- collect (+ 33 (random 94)) into auth
- finally return (concat auth))))
+ (let ((auth-key (server-get-auth-key)))
(process-put server-process :auth-key auth-key)
(with-temp-file server-file
(set-buffer-multibyte nil)
(pp v)
(let ((text (buffer-substring-no-properties
(point-min) (point-max))))
- (server-send-string
- proc (format "-print %s\n"
- (server-quote-arg text)))))))))
+ (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
+ (if (string-match "\\(^\\|[^&]\\)\\(&&\\)+$" part)
+ ;; 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"))))
(defun server-create-tty-frame (tty type proc)
(unless tty
(select-frame frame)
(process-put proc 'frame frame)
(process-put proc 'terminal (frame-terminal frame))
-
- ;; Display *scratch* by default.
- (switch-to-buffer (get-buffer-create "*scratch*") 'norecord)
-
frame))
(defun server-create-window-system-frame (display nowait proc parent-id
(select-frame frame)
(process-put proc 'frame frame)
(process-put proc 'terminal (frame-terminal frame))
-
- ;; Display *scratch* by default.
- (switch-to-buffer (get-buffer-create "*scratch*") 'norecord)
frame)))
(defun server-goto-toplevel (proc)
(process-put proc 'continuation nil)
(if continuation (ignore-errors (funcall continuation)))))
-(defun* server-process-filter (proc string)
+(cl-defun server-process-filter (proc string)
"Process a request from the server to edit some files.
PROC is the server process. STRING consists of a sequence of
commands prefixed by a dash. Some commands have arguments;
Print STRING on stdout. Used to send values
returned by -eval.
+`-print-nonl STRING'
+ Print STRING on stdout. Used to continue a
+ preceding -print command that would be too big to send
+ in a single message.
+
`-error DESCRIPTION'
Signal an error and delete process PROC.
;; receive the error string and shut down on its own.
(sit-for 1)
(delete-process proc)
- ;; We return immediately
- (return-from server-process-filter)))
+ ;; We return immediately.
+ (cl-return-from server-process-filter)))
(let ((prev (process-get proc 'previous-string)))
(when prev
(setq string (concat prev string))
;; In earlier versions of server.el (where we used an `emacsserver'
;; process), there could be multiple lines. Nowadays this is not
;; supported any more.
- (assert (eq (match-end 0) (length string)))
+ (cl-assert (eq (match-end 0) (length string)))
(let ((request (substring string 0 (match-beginning 0)))
(coding-system (and (default-value 'enable-multibyte-characters)
(or file-name-coding-system
;; -window-system: Open a new X frame.
(`"-window-system"
- (setq dontkill t)
- (setq tty-name 'window-system))
+ (if (fboundp 'x-create-frame)
+ (setq dontkill t
+ tty-name 'window-system)))
;; -resume: Resume a suspended tty frame.
(`"-resume"
(setq dontkill t)
(pop args-left))
- ;; -tty DEVICE-NAME TYPE: Open a new tty frame at the client.
+ ;; -tty DEVICE-NAME TYPE: Open a new tty frame.
+ ;; (But if we see -window-system later, use that.)
(`"-tty"
(setq tty-name (pop args-left)
tty-type (pop args-left)
(setq dir (pop args-left))
(if coding-system
(setq dir (decode-coding-string dir coding-system)))
- (setq dir (command-line-normalize-file-name dir)))
+ (setq dir (command-line-normalize-file-name dir))
+ (process-put proc 'server-client-directory dir))
;; Unknown command.
(arg (error "Unknown command: %s" arg))))
+ ;; If both -no-wait and -tty are given with file or sexp
+ ;; arguments, use an existing frame.
+ (and nowait
+ (not (eq tty-name 'window-system))
+ (or files commands)
+ (setq use-current-frame t))
+
(setq frame
(cond
((and use-current-frame
;; including code that needs to wait.
(with-local-quit
(condition-case err
- (let* ((buffers
- (when files
- (server-visit-files files proc nowait))))
-
+ (let ((buffers (server-visit-files files proc nowait)))
(mapc 'funcall (nreverse commands))
+ ;; If we were told only to open a new client, obey
+ ;; `initial-buffer-choice' if it specifies a file.
+ (unless (or files commands)
+ (if (stringp initial-buffer-choice)
+ (find-file initial-buffer-choice)
+ (switch-to-buffer (get-buffer-create "*scratch*")
+ 'norecord)))
+
;; Delete the client if necessary.
(cond
(nowait
Returns the result of the evaluation, or signals an error if it
cannot contact the specified server. For example:
\(server-eval-at \"server\" '(emacs-pid))
-returns the process ID of the Emacs instance running \"server\".
-This function requires the use of TCP sockets. "
- (or server-use-tcp
- (error "This function requires TCP sockets"))
- (let ((auth-file (expand-file-name server server-auth-dir))
- (coding-system-for-read 'binary)
- (coding-system-for-write 'binary)
- address port secret process)
- (unless (file-exists-p auth-file)
- (error "No such server definition: %s" auth-file))
+returns the process ID of the Emacs instance running \"server\"."
+ (let* ((server-dir (if server-use-tcp server-auth-dir server-socket-dir))
+ (server-file (expand-file-name server server-dir))
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ address port secret process)
+ (unless (file-exists-p server-file)
+ (error "No such server: %s" server))
(with-temp-buffer
- (insert-file-contents auth-file)
- (unless (looking-at "\\([0-9.]+\\):\\([0-9]+\\)")
- (error "Invalid auth file"))
- (setq address (match-string 1)
- port (string-to-number (match-string 2)))
- (forward-line 1)
- (setq secret (buffer-substring (point) (line-end-position)))
- (erase-buffer)
- (unless (setq process (open-network-stream "eval-at" (current-buffer)
- address port))
- (error "Unable to contact the server"))
- (set-process-query-on-exit-flag process nil)
- (process-send-string
- process
- (concat "-auth " secret " -eval "
- (replace-regexp-in-string
- " " "&_" (format "%S" form))
- "\n"))
+ (when server-use-tcp
+ (let ((coding-system-for-read 'no-conversion))
+ (insert-file-contents server-file)
+ (unless (looking-at "\\([0-9.]+\\):\\([0-9]+\\)")
+ (error "Invalid auth file"))
+ (setq address (match-string 1)
+ port (string-to-number (match-string 2)))
+ (forward-line 1)
+ (setq secret (buffer-substring (point) (line-end-position)))
+ (erase-buffer)))
+ (unless (setq process (make-network-process
+ :name "eval-at"
+ :buffer (current-buffer)
+ :host address
+ :service (if server-use-tcp port server-file)
+ :family (if server-use-tcp 'ipv4 'local)
+ :noquery t))
+ (error "Unable to contact the server"))
+ (if server-use-tcp
+ (process-send-string process (concat "-auth " secret "\n")))
+ (process-send-string process
+ (concat "-eval "
+ (server-quote-arg (format "%S" form))
+ "\n"))
(while (memq (process-status process) '(open run))
(accept-process-output process 0 10))
(goto-char (point-min))
;; If the result is nil, there's nothing in the buffer. If the
;; result is non-nil, it's after "-print ".
- (when (search-forward "\n-print" nil t)
- (let ((start (point)))
- (while (search-forward "&_" nil t)
- (replace-match " " t t))
- (goto-char start)
- (read (current-buffer)))))))
+ (let ((answer ""))
+ (while (re-search-forward "\n-print\\(-nonl\\)? " nil t)
+ (setq answer
+ (concat answer
+ (buffer-substring (point)
+ (progn (skip-chars-forward "^\n")
+ (point))))))
+ (if (not (equal answer ""))
+ (read (decode-coding-string (server-unquote-arg answer)
+ 'emacs-internal)))))))
\f
(provide 'server)
HCoop / bpt / emacs.git / blobdiff