X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/a8e7d6d783219972c08fd49a3a2afaf26eb139c2..af39894ab4b8a68eef14b39c030577b419a582a8:/lisp/server.el diff --git a/lisp/server.el b/lisp/server.el index 1e2f458ac9..c78e3e376a 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -81,7 +81,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup server nil "Emacs running as a server process." @@ -94,7 +94,6 @@ (setq val t) (unless load-in-progress (message "Local sockets unsupported, using TCP sockets"))) - (when val (random t)) (set-default sym val)) :group 'server :type 'boolean @@ -102,7 +101,12 @@ (defcustom server-host nil "The name or IP address to use as host address of the server process. -If set, the server accepts remote connections; otherwise it is local." +If set, the server accepts remote connections; otherwise it is local. + +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." :group 'server :type '(choice (string :tag "Name or IP address") @@ -141,12 +145,12 @@ directory residing in a NTFS partition instead." (defcustom server-auth-key nil "Server authentication key. +This is only used if `server-use-tcp' is non-nil. 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). +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). In some situations however, it can be difficult to share randomly generated passwords with remote hosts (eg. no shared directory), @@ -154,16 +158,18 @@ 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). +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. -You can use \\[server-generate-key] to get a random authentication -key." +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." :group 'server :type '(choice (const :tag "Random" nil) (string :tag "Password")) - :version "24.2") + :version "24.3") (defcustom server-raise-frame t "If non-nil, raise frame when switching to a buffer." @@ -478,11 +484,11 @@ If CLIENT is non-nil, add a description of it to the logged message." 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) @@ -493,7 +499,7 @@ contains a space. 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") @@ -514,7 +520,7 @@ Creates the directory if necessary and makes sure: (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. @@ -550,9 +556,9 @@ 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 - (loop repeat 64 - collect (+ 33 (random 94)) into auth - finally return (concat auth)))) + (cl-loop repeat 64 + collect (+ 33 (random 94)) into auth + finally return (concat auth)))) (if (called-interactively-p 'interactive) (insert auth-key)) auth-key)) @@ -632,11 +638,13 @@ server or call `M-x server-force-delete' to forcibly disconnect it.") (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 @@ -825,35 +833,49 @@ This handles splitting the command if it would be bigger than (defun server-create-window-system-frame (display nowait proc parent-id &optional parameters) - (add-to-list 'frame-inherited-parameters 'client) - (if (not (fboundp 'make-frame-on-display)) - (progn - ;; This emacs does not support X. - (server-log "Window system unsupported" proc) - (server-send-string proc "-window-system-unsupported \n") - nil) - ;; 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)) - (display (or display - (frame-parameter nil 'display) - (getenv "DISPLAY") - (error "Please specify display"))) - frame) - (if parent-id - (push (cons 'parent-id (string-to-number parent-id)) params)) - (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))) + (let* ((display (or display + (frame-parameter nil 'display) + (error "Please specify display."))) + (w (or (cdr (assq 'window-system parameters)) + (window-system-for-display display)))) + + (unless (assq w window-system-initialization-alist) + (setq w nil)) + + ;; 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. + (if (featurep 'ns-win) + (setq w 'ns display "ns")) + + (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)))) (defun server-goto-toplevel (proc) (condition-case nil @@ -886,7 +908,7 @@ This handles splitting the command if it would be bigger than (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; @@ -1001,8 +1023,8 @@ The following commands are accepted by the client: ;; 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)) @@ -1021,7 +1043,7 @@ The following commands are accepted by the client: ;; 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 @@ -1113,9 +1135,13 @@ The following commands are accepted by the client: tty-type (pop args-left) dontkill (or dontkill (not use-current-frame))) - ;; On Windows, emacsclient always asks for a tty frame. - ;; If running a GUI server, force the frame type to GUI. - (when (eq window-system 'w32) + ;; On Windows, emacsclient always asks for a tty + ;; frame. If running a GUI server, force the frame + ;; type to GUI. (Cygwin is perfectly happy with + ;; multi-tty support, so don't override the user's + ;; choice there.) + (when (and (eq system-type 'windows-nt) + (eq window-system 'w32)) (push "-window-system" args-left))) ;; -position LINE[:COLUMN]: Set point to the given @@ -1164,7 +1190,8 @@ The following commands are accepted by the client: (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))))