diff options
| author | Stefan Monnier | 2006-11-02 23:46:14 +0000 |
|---|---|---|
| committer | Stefan Monnier | 2006-11-02 23:46:14 +0000 |
| commit | 757e168190bd44b117f920b6794e5cef4efcaa41 (patch) | |
| tree | 46675035011c3cee210fad69ca2d0c54a325c85b | |
| parent | b193caa336c5d0b495933f149abe3407734a455f (diff) | |
| download | emacs-757e168190bd44b117f920b6794e5cef4efcaa41.tar.gz emacs-757e168190bd44b117f920b6794e5cef4efcaa41.zip | |
(server-auth-key): Remove. Replace by a process-property.
(server-start): Don't remove the file of the previous process, but
instead clear out the place for the new file.
(server-start): Set the :auth-key property.
(server-process-filter): Use the :auth-key property.
| -rw-r--r-- | lisp/ChangeLog | 8 | ||||
| -rw-r--r-- | lisp/server.el | 103 |
2 files changed, 59 insertions, 52 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c60fd681d69..14eb059a1ff 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog | |||
| @@ -1,3 +1,11 @@ | |||
| 1 | 2006-11-02 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | * server.el (server-auth-key): Remove. Replace by a process-property. | ||
| 4 | (server-start): Don't remove the file of the previous process, but | ||
| 5 | instead clear out the place for the new file. | ||
| 6 | (server-start): Set the :auth-key property. | ||
| 7 | (server-process-filter): Use the :auth-key property. | ||
| 8 | |||
| 1 | 2006-11-02 Carsten Dominik <dominik@science.uva.nl> | 9 | 2006-11-02 Carsten Dominik <dominik@science.uva.nl> |
| 2 | 10 | ||
| 3 | * textmodes/org.el (org-mode-map): No longer copy | 11 | * textmodes/org.el (org-mode-map): No longer copy |
diff --git a/lisp/server.el b/lisp/server.el index 7f2962fcc69..1b32ed11228 100644 --- a/lisp/server.el +++ b/lisp/server.el | |||
| @@ -112,10 +112,6 @@ If set, the server accepts remote connections; otherwise it is local." | |||
| 112 | :version "22.1") | 112 | :version "22.1") |
| 113 | (put 'server-auth-dir 'risky-local-variable t) | 113 | (put 'server-auth-dir 'risky-local-variable t) |
| 114 | 114 | ||
| 115 | (defvar server-auth-key nil | ||
| 116 | "The current server authentication key.") | ||
| 117 | (put 'server-auth-key 'risky-local-variable t) | ||
| 118 | |||
| 119 | (defcustom server-visit-hook nil | 115 | (defcustom server-visit-hook nil |
| 120 | "*Hook run when visiting a file for the Emacs server." | 116 | "*Hook run when visiting a file for the Emacs server." |
| 121 | :group 'server | 117 | :group 'server |
| @@ -228,6 +224,12 @@ are done with it in the server.") | |||
| 228 | (when (and (eq (process-status proc) 'open) | 224 | (when (and (eq (process-status proc) 'open) |
| 229 | (process-query-on-exit-flag proc)) | 225 | (process-query-on-exit-flag proc)) |
| 230 | (set-process-query-on-exit-flag proc nil)) | 226 | (set-process-query-on-exit-flag proc nil)) |
| 227 | ;; Delete the associated connection file, if applicable. | ||
| 228 | ;; This is actually problematic: the file may have been overwritten by | ||
| 229 | ;; another Emacs server in the mean time, so it's not ours any more. | ||
| 230 | ;; (and (process-contact proc :server) | ||
| 231 | ;; (eq (process-status proc) 'closed) | ||
| 232 | ;; (ignore-errors (delete-file (process-get proc :server-file)))) | ||
| 231 | (server-log (format "Status changed to %s" (process-status proc)) proc)) | 233 | (server-log (format "Status changed to %s" (process-status proc)) proc)) |
| 232 | 234 | ||
| 233 | (defun server-select-display (display) | 235 | (defun server-select-display (display) |
| @@ -307,61 +309,58 @@ Prefix arg means just kill any existing server communications subprocess." | |||
| 307 | (interactive "P") | 309 | (interactive "P") |
| 308 | (when server-process | 310 | (when server-process |
| 309 | ;; kill it dead! | 311 | ;; kill it dead! |
| 310 | (ignore-errors (delete-process server-process)) | 312 | (ignore-errors (delete-process server-process))) |
| 311 | (ignore-errors | ||
| 312 | ;; Delete the socket or authentication files made by previous | ||
| 313 | ;; server invocations. | ||
| 314 | (if (eq (process-contact server-process :family) 'local) | ||
| 315 | (delete-file (expand-file-name server-name server-socket-dir)) | ||
| 316 | (setq server-auth-key nil) | ||
| 317 | (delete-file (expand-file-name server-name server-auth-dir))))) | ||
| 318 | ;; If this Emacs already had a server, clear out associated status. | 313 | ;; If this Emacs already had a server, clear out associated status. |
| 319 | (while server-clients | 314 | (while server-clients |
| 320 | (let ((buffer (nth 1 (car server-clients)))) | 315 | (let ((buffer (nth 1 (car server-clients)))) |
| 321 | (server-buffer-done buffer))) | 316 | (server-buffer-done buffer))) |
| 322 | ;; Now any previous server is properly stopped. | 317 | ;; Now any previous server is properly stopped. |
| 323 | (unless leave-dead | 318 | (unless leave-dead |
| 324 | ;; Make sure there is a safe directory in which to place the socket. | 319 | (let* ((server-dir (if server-use-tcp server-auth-dir server-socket-dir)) |
| 325 | (server-ensure-safe-dir | 320 | (server-file (expand-file-name server-name server-dir))) |
| 326 | (if server-use-tcp server-auth-dir server-socket-dir)) | 321 | ;; Make sure there is a safe directory in which to place the socket. |
| 327 | (when server-process | 322 | (server-ensure-safe-dir server-dir) |
| 328 | (server-log (message "Restarting server"))) | 323 | ;; Remove any leftover socket or authentication file. |
| 329 | (letf (((default-file-modes) ?\700)) | 324 | (ignore-errors (delete-file server-file)) |
| 330 | (setq server-process | 325 | (when server-process |
| 331 | (apply #'make-network-process | 326 | (server-log (message "Restarting server"))) |
| 332 | :name server-name | 327 | (letf (((default-file-modes) ?\700)) |
| 333 | :server t | 328 | (setq server-process |
| 334 | :noquery t | 329 | (apply #'make-network-process |
| 335 | :sentinel 'server-sentinel | 330 | :name server-name |
| 336 | :filter 'server-process-filter | 331 | :server t |
| 337 | ;; We must receive file names without being decoded. | 332 | :noquery t |
| 338 | ;; Those are decoded by server-process-filter according | 333 | :sentinel 'server-sentinel |
| 339 | ;; to file-name-coding-system. | 334 | :filter 'server-process-filter |
| 340 | :coding 'raw-text | 335 | ;; We must receive file names without being decoded. |
| 341 | ;; The rest of the args depends on the kind of socket used. | 336 | ;; Those are decoded by server-process-filter according |
| 342 | (if server-use-tcp | 337 | ;; to file-name-coding-system. |
| 343 | (list :family nil | 338 | :coding 'raw-text |
| 344 | :service t | 339 | ;; The rest of the args depends on the kind of socket used. |
| 345 | :host (or server-host 'local) | 340 | (if server-use-tcp |
| 346 | :plist '(:authenticated nil)) | 341 | (list :family nil |
| 347 | (list :family 'local | 342 | :service t |
| 348 | :service (expand-file-name server-name server-socket-dir) | 343 | :host (or server-host 'local) |
| 349 | :plist '(:authenticated t))))) | 344 | :plist '(:authenticated nil)) |
| 345 | (list :family 'local | ||
| 346 | :service server-file | ||
| 347 | :plist '(:authenticated t))))) | ||
| 350 | (unless server-process (error "Could not start server process")) | 348 | (unless server-process (error "Could not start server process")) |
| 351 | (when server-use-tcp | 349 | (when server-use-tcp |
| 352 | (setq server-auth-key | 350 | (let ((auth-key |
| 353 | (loop | 351 | (loop |
| 354 | ;; The auth key is a 64-byte string of random chars in the | 352 | ;; The auth key is a 64-byte string of random chars in the |
| 355 | ;; range `!'..`~'. | 353 | ;; range `!'..`~'. |
| 356 | for i below 64 | 354 | for i below 64 |
| 357 | collect (+ 33 (random 94)) into auth | 355 | collect (+ 33 (random 94)) into auth |
| 358 | finally return (concat auth))) | 356 | finally return (concat auth)))) |
| 359 | (with-temp-file (expand-file-name server-name server-auth-dir) | 357 | (process-put server-process :auth-key auth-key) |
| 360 | (set-buffer-multibyte nil) | 358 | (with-temp-file server-file |
| 361 | (setq buffer-file-coding-system 'no-conversion) | 359 | (set-buffer-multibyte nil) |
| 362 | (insert (format-network-address | 360 | (setq buffer-file-coding-system 'no-conversion) |
| 363 | (process-contact server-process :local)) | 361 | (insert (format-network-address |
| 364 | "\n" server-auth-key)))))) | 362 | (process-contact server-process :local)) |
| 363 | "\n" auth-key)))))))) | ||
| 365 | 364 | ||
| 366 | ;;;###autoload | 365 | ;;;###autoload |
| 367 | (define-minor-mode server-mode | 366 | (define-minor-mode server-mode |
| @@ -382,7 +381,7 @@ PROC is the server process. Format of STRING is \"PATH PATH PATH... \\n\"." | |||
| 382 | ;; First things first: let's check the authentication | 381 | ;; First things first: let's check the authentication |
| 383 | (unless (process-get proc :authenticated) | 382 | (unless (process-get proc :authenticated) |
| 384 | (if (and (string-match "-auth \\(.*?\\)\n" string) | 383 | (if (and (string-match "-auth \\(.*?\\)\n" string) |
| 385 | (string= (match-string 1 string) server-auth-key)) | 384 | (equal (match-string 1 string) (process-get proc :auth-key))) |
| 386 | (progn | 385 | (progn |
| 387 | (setq string (substring string (match-end 0))) | 386 | (setq string (substring string (match-end 0))) |
| 388 | (process-put proc :authenticated t) | 387 | (process-put proc :authenticated t) |