Mercurial > emacs
comparison lisp/server.el @ 47612:2d55f7e8ff64
Use built-in network primitives.
(server-program, server-previous-string): Remove.
(server-previous-strings): New var.
(server-socket-name): New var.
(server-log): Minor change to the output format.
(server-sentinel): Clean up global state when a client disconnects.
(server-unquote-arg): New fun.
(server-start): Use server-socket-name and make-network-process.
(server-process-filter): Now talks to the clients directly.
Normalize file name after unquoting and decoding.
(server-buffer-done): Just close the connection.
(server-switch-buffer): Handle the case where all windows are
dedicated or minibuffers.
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Wed, 25 Sep 2002 19:54:13 +0000 |
parents | 95ba2ac51138 |
children | d033b85fc797 |
comparison
equal
deleted
inserted
replaced
47611:6bc56530304a | 47612:2d55f7e8ff64 |
---|---|
80 | 80 |
81 (defgroup server nil | 81 (defgroup server nil |
82 "Emacs running as a server process." | 82 "Emacs running as a server process." |
83 :group 'external) | 83 :group 'external) |
84 | 84 |
85 (defcustom server-program (expand-file-name "emacsserver" exec-directory) | 85 (defcustom server-visit-hook nil |
86 "*The program to use as the edit server." | 86 "*Hook run when visiting a file for the Emacs server." |
87 :group 'server | 87 :group 'server |
88 :type 'string) | 88 :type 'hook) |
89 | 89 |
90 (defcustom server-visit-hook nil | 90 (defcustom server-switch-hook nil |
91 "*List of hooks to call when visiting a file for the Emacs server." | 91 "*Hook run when switching to a buffer for the Emacs server." |
92 :group 'server | 92 :group 'server |
93 :type '(repeat function)) | 93 :type 'hook) |
94 | 94 |
95 (defcustom server-switch-hook nil | 95 (defcustom server-done-hook nil |
96 "*List of hooks to call when switching to a buffer for the Emacs server." | 96 "*Hook run when done editing a buffer for the Emacs server." |
97 :group 'server | 97 :group 'server |
98 :type '(repeat function)) | 98 :type 'hook) |
99 | |
100 (defcustom server-done-hook nil | |
101 "*List of hooks to call when done editing a buffer for the Emacs server." | |
102 :group 'server | |
103 :type '(repeat function)) | |
104 | 99 |
105 (defvar server-process nil | 100 (defvar server-process nil |
106 "The current server process") | 101 "The current server process") |
107 | 102 |
108 (defvar server-previous-string "") | 103 (defvar server-previous-strings nil) |
109 | 104 |
110 (defvar server-clients nil | 105 (defvar server-clients nil |
111 "List of current server clients. | 106 "List of current server clients. |
112 Each element is (CLIENTID BUFFERS...) where CLIENTID is a string | 107 Each element is (CLIENTID BUFFERS...) where CLIENTID is a string |
113 that can be given to the server process to identify a client. | 108 that can be given to the server process to identify a client. |
150 "Non-nil means the buffer existed before the server was asked to visit it. | 145 "Non-nil means the buffer existed before the server was asked to visit it. |
151 This means that the server should not kill the buffer when you say you | 146 This means that the server should not kill the buffer when you say you |
152 are done with it in the server.") | 147 are done with it in the server.") |
153 (make-variable-buffer-local 'server-existing-buffer) | 148 (make-variable-buffer-local 'server-existing-buffer) |
154 | 149 |
150 (defvar server-socket-name | |
151 (if (or (not (file-writable-p "~/")) | |
152 (and (file-writable-p "/tmp/") | |
153 (not (zerop (logand (file-modes "/tmp/") 512))))) | |
154 (format "/tmp/esrv%d-%s" (user-uid) (system-name)) | |
155 (format "~/.emacs-server-%s" (system-name)))) | |
156 | |
155 ;; If a *server* buffer exists, | 157 ;; If a *server* buffer exists, |
156 ;; write STRING to it for logging purposes. | 158 ;; write STRING to it for logging purposes. |
157 (defun server-log (string &optional client) | 159 (defun server-log (string &optional client) |
158 (if (get-buffer "*server*") | 160 (if (get-buffer "*server*") |
159 (with-current-buffer "*server*" | 161 (with-current-buffer "*server*" |
160 (goto-char (point-max)) | 162 (goto-char (point-max)) |
161 (insert (current-time-string) | 163 (insert (current-time-string) |
162 (if client (format " <%s>: " client) " ") | 164 (if client (format " %s:" client) " ") |
163 string) | 165 string) |
164 (or (bolp) (newline))))) | 166 (or (bolp) (newline))))) |
165 | 167 |
166 (defun server-sentinel (proc msg) | 168 (defun server-sentinel (proc msg) |
167 (cond ((eq (process-status proc) 'exit) | 169 ;; Purge server-previous-strings of the now irrelevant entry. |
168 (server-log (message "Server subprocess exited"))) | 170 (setq server-previous-strings |
169 ((eq (process-status proc) 'signal) | 171 (delq (assq proc server-previous-strings) server-previous-strings)) |
170 (server-log (message "Server subprocess killed"))))) | 172 (let ((ps (assq proc server-clients))) |
173 (dolist (buf (cdr ps)) | |
174 (with-current-buffer buf | |
175 ;; Remove PROC from the clients of each buffer. | |
176 (setq server-buffer-clients (delq proc server-buffer-clients)))) | |
177 ;; Remove PROC from the list of clients. | |
178 (if ps (setq server-clients (delq ps server-clients)))) | |
179 (server-log (format "Status changed to %s" (process-status proc)) proc)) | |
180 | |
181 (defun server-unquote-arg (arg) | |
182 (replace-regexp-in-string | |
183 "&." (lambda (s) | |
184 (case (aref s 1) | |
185 (?& "&") | |
186 (?- "-") | |
187 (?n "\n") | |
188 (t " "))) | |
189 arg t t)) | |
171 | 190 |
172 ;;;###autoload | 191 ;;;###autoload |
173 (defun server-start (&optional leave-dead) | 192 (defun server-start (&optional leave-dead) |
174 "Allow this Emacs process to be a server for client processes. | 193 "Allow this Emacs process to be a server for client processes. |
175 This starts a server communications subprocess through which | 194 This starts a server communications subprocess through which |
180 Prefix arg means just kill any existing server communications subprocess." | 199 Prefix arg means just kill any existing server communications subprocess." |
181 (interactive "P") | 200 (interactive "P") |
182 ;; kill it dead! | 201 ;; kill it dead! |
183 (condition-case () (delete-process server-process) (error nil)) | 202 (condition-case () (delete-process server-process) (error nil)) |
184 ;; Delete the socket files made by previous server invocations. | 203 ;; Delete the socket files made by previous server invocations. |
185 (let* ((sysname (system-name)) | 204 (condition-case () (delete-file server-socket-name) (error nil)) |
186 (dot-index (string-match "\\." sysname))) | |
187 (condition-case () | |
188 (delete-file (format "~/.emacs-server-%s" sysname)) | |
189 (error nil)) | |
190 (condition-case () | |
191 (delete-file (format "/tmp/esrv%d-%s" (user-uid) sysname)) | |
192 (error nil)) | |
193 ;; In case the server file name was made with a domainless hostname, | |
194 ;; try deleting that name too. | |
195 (if dot-index | |
196 (let ((shortname (substring sysname 0 dot-index))) | |
197 (condition-case () | |
198 (delete-file (format "~/.emacs-server-%s" shortname)) | |
199 (error nil)) | |
200 (condition-case () | |
201 (delete-file (format "/tmp/esrv%d-%s" (user-uid) shortname)) | |
202 (error nil))))) | |
203 ;; If this Emacs already had a server, clear out associated status. | 205 ;; If this Emacs already had a server, clear out associated status. |
204 (while server-clients | 206 (while server-clients |
205 (let ((buffer (nth 1 (car server-clients)))) | 207 (let ((buffer (nth 1 (car server-clients)))) |
206 (server-buffer-done buffer))) | 208 (server-buffer-done buffer))) |
207 (unless leave-dead | 209 (unless leave-dead |
208 (if server-process | 210 (if server-process |
209 (server-log (message "Restarting server"))) | 211 (server-log (message "Restarting server"))) |
210 ;; Using a pty is wasteful, and the separate session causes | 212 (let ((umask (default-file-modes))) |
211 ;; annoyance sometimes (some systems kill idle sessions). | 213 (unwind-protect |
212 (let ((process-connection-type nil)) | 214 (progn |
213 (setq server-process (start-process "server" nil server-program))) | 215 (set-default-file-modes ?\700) |
214 (set-process-sentinel server-process 'server-sentinel) | 216 (setq server-process |
215 (set-process-filter server-process 'server-process-filter) | 217 (make-network-process |
216 ;; We must receive file names without being decoded. Those are | 218 :name "server" :family 'local :server t :noquery t |
217 ;; decoded by server-process-filter accoding to | 219 :service server-socket-name |
218 ;; file-name-coding-system. | 220 :sentinel 'server-sentinel :filter 'server-process-filter |
219 (set-process-coding-system server-process 'raw-text 'raw-text) | 221 ;; We must receive file names without being decoded. |
220 (process-kill-without-query server-process))) | 222 ;; Those are decoded by server-process-filter according |
223 ;; to file-name-coding-system. | |
224 :coding 'raw-text))) | |
225 (set-default-file-modes umask))))) | |
221 | 226 |
222 ;Process a request from the server to edit some files. | 227 ;Process a request from the server to edit some files. |
223 ;Format of STRING is "Client: CLIENTID PATH PATH PATH... \n" | 228 ;Format of STRING is "PATH PATH PATH... \n" |
224 (defun server-process-filter (proc string) | 229 (defun server-process-filter (proc string) |
225 (server-log string) | 230 (server-log string proc) |
226 (setq string (concat server-previous-string string)) | 231 (let ((ps (assq proc server-previous-strings))) |
232 (when (cdr ps) | |
233 (setq string (concat (cdr ps) string)) | |
234 (setcdr ps nil))) | |
227 ;; If the input is multiple lines, | 235 ;; If the input is multiple lines, |
228 ;; process each line individually. | 236 ;; process each line individually. |
229 (while (string-match "\n" string) | 237 (while (string-match "\n" string) |
230 (let ((request (substring string 0 (match-beginning 0))) | 238 (let ((request (substring string 0 (match-beginning 0))) |
231 (coding-system (and default-enable-multibyte-characters | 239 (coding-system (and default-enable-multibyte-characters |
234 client nowait | 242 client nowait |
235 (files nil) | 243 (files nil) |
236 (lineno 1) | 244 (lineno 1) |
237 (columnno 0)) | 245 (columnno 0)) |
238 ;; Remove this line from STRING. | 246 ;; Remove this line from STRING. |
239 (setq string (substring string (match-end 0))) | 247 (setq string (substring string (match-end 0))) |
240 (if (string-match "^Error: " request) | 248 (setq client (cons proc nil)) |
241 (message "Server error: %s" (substring request (match-end 0))) | 249 (while (string-match "[^ ]* " request) |
242 (if (string-match "^Client: " request) | 250 (let ((arg (substring request (match-beginning 0) (1- (match-end 0)))) |
243 (progn | 251 (pos 0)) |
244 (setq request (substring request (match-end 0))) | 252 (setq request (substring request (match-end 0))) |
245 (setq client (list (substring request 0 (string-match " " request)))) | 253 (cond |
246 (setq request (substring request (match-end 0))) | 254 ((equal "-nowait" arg) (setq nowait t)) |
247 (while (string-match "[^ ]+ " request) | 255 ;; ARG is a line number option. |
248 (let ((arg | 256 ((string-match "\\`\\+[0-9]+\\'" arg) |
249 (substring request (match-beginning 0) (1- (match-end 0)))) | 257 (setq lineno (string-to-int (substring arg 1)))) |
250 (pos 0)) | 258 ;; ARG is line number:column option. |
251 (setq request (substring request (match-end 0))) | 259 ((string-match "\\`+\\([0-9]+\\):\\([0-9]+\\)\\'" arg) |
252 (cond | 260 (setq lineno (string-to-int (match-string 1 arg)) |
253 ((string-match "\\`-nowait" arg) | 261 columnno (string-to-int (match-string 2 arg)))) |
254 (setq nowait t)) | 262 (t |
255 ;; ARG is a line number option. | 263 ;; Undo the quoting that emacsclient does |
256 ((string-match "\\`\\+[0-9]+\\'" arg) | 264 ;; for certain special characters. |
257 (setq lineno (string-to-int (substring arg 1)))) | 265 (setq arg (server-unquote-arg arg)) |
258 ;; ARG is line number:column option. | 266 ;; Now decode the file name if necessary. |
259 ((string-match "\\`+\\([0-9]+\\):\\([0-9]+\\)\\'" arg) | 267 (if coding-system |
260 (setq lineno (string-to-int (match-string 1 arg)) | 268 (setq arg (decode-coding-string arg coding-system))) |
261 columnno (string-to-int (match-string 2 arg)))) | 269 ;; ARG is a file name. |
262 (t | 270 ;; Collapse multiple slashes to single slashes. |
263 ;; ARG is a file name. | 271 (setq arg (command-line-normalize-file-name arg)) |
264 ;; Collapse multiple slashes to single slashes. | 272 (push (list arg lineno columnno) files) |
265 (setq arg (command-line-normalize-file-name arg)) | 273 (setq lineno 1) |
266 ;; Undo the quoting that emacsclient does | 274 (setq columnno 0))))) |
267 ;; for certain special characters. | 275 (when files |
268 (setq arg | 276 (run-hooks 'pre-command-hook) |
269 (replace-regexp-in-string | 277 (server-visit-files files client nowait) |
270 "&." (lambda (s) | 278 (run-hooks 'post-command-hook)) |
271 (case (aref s 1) | 279 ;; CLIENT is now a list (CLIENTNUM BUFFERS...) |
272 (?& "&") | 280 (if (null (cdr client)) |
273 (?- "-") | 281 ;; This client is empty; get rid of it immediately. |
274 (?n "\n") | 282 (progn |
275 (t " "))) | 283 (delete-process proc) |
276 arg t t)) | 284 (server-log "Close empty client" proc)) |
277 ;; Now decode the file name if necessary. | 285 ;; We visited some buffer for this client. |
278 (if coding-system | 286 (or nowait (push client server-clients)) |
279 (setq arg (decode-coding-string arg coding-system))) | 287 (server-switch-buffer (nth 1 client)) |
280 (push (list arg lineno columnno) files) | 288 (run-hooks 'server-switch-hook) |
281 (setq lineno 1) | 289 (unless nowait |
282 (setq columnno 0))))) | 290 (message (substitute-command-keys |
283 (when files | 291 "When done with a buffer, type \\[server-edit]")))))) |
284 (run-hooks 'pre-command-hook) | |
285 (server-visit-files files client nowait) | |
286 (run-hooks 'post-command-hook)) | |
287 ;; CLIENT is now a list (CLIENTNUM BUFFERS...) | |
288 (if (null (cdr client)) | |
289 ;; This client is empty; get rid of it immediately. | |
290 (progn | |
291 (send-string server-process | |
292 (format "Close: %s Done\n" (car client))) | |
293 (server-log "Close empty client" (car client))) | |
294 ;; We visited some buffer for this client. | |
295 (or nowait (push client server-clients)) | |
296 (server-switch-buffer (nth 1 client)) | |
297 (run-hooks 'server-switch-hook) | |
298 (unless nowait | |
299 (message (substitute-command-keys | |
300 "When done with a buffer, type \\[server-edit]"))))))))) | |
301 ;; Save for later any partial line that remains. | 292 ;; Save for later any partial line that remains. |
302 (setq server-previous-string string)) | 293 (when (> (length string) 0) |
294 (let ((ps (assq proc server-previous-strings))) | |
295 (if ps (setcdr ps string) | |
296 (push (cons proc string) server-previous-strings))))) | |
303 | 297 |
304 (defun server-goto-line-column (file-line-col) | 298 (defun server-goto-line-column (file-line-col) |
305 (goto-line (nth 1 file-line-col)) | 299 (goto-line (nth 1 file-line-col)) |
306 (let ((column-number (nth 2 file-line-col))) | 300 (let ((column-number (nth 2 file-line-col))) |
307 (if (> column-number 0) | 301 (if (> column-number 0) |
354 This buries the buffer, then returns a list of the form (NEXT-BUFFER KILLED). | 348 This buries the buffer, then returns a list of the form (NEXT-BUFFER KILLED). |
355 NEXT-BUFFER is another server buffer, as a suggestion for what to select next, | 349 NEXT-BUFFER is another server buffer, as a suggestion for what to select next, |
356 or nil. KILLED is t if we killed BUFFER (typically, because it was visiting | 350 or nil. KILLED is t if we killed BUFFER (typically, because it was visiting |
357 a temp file). | 351 a temp file). |
358 FOR-KILLING if non-nil indicates that we are called from `kill-buffer'." | 352 FOR-KILLING if non-nil indicates that we are called from `kill-buffer'." |
359 (let ((running (eq (process-status server-process) 'run)) | 353 (let ((next-buffer nil) |
360 (next-buffer nil) | |
361 (killed nil) | 354 (killed nil) |
362 (first t) | |
363 (old-clients server-clients)) | 355 (old-clients server-clients)) |
364 (while old-clients | 356 (while old-clients |
365 (let ((client (car old-clients))) | 357 (let ((client (car old-clients))) |
366 (or next-buffer | 358 (or next-buffer |
367 (setq next-buffer (nth 1 (memq buffer client)))) | 359 (setq next-buffer (nth 1 (memq buffer client)))) |
373 (null (buffer-name (car tail))) | 365 (null (buffer-name (car tail))) |
374 (delq (car tail) client)) | 366 (delq (car tail) client)) |
375 (setq tail (cdr tail)))) | 367 (setq tail (cdr tail)))) |
376 ;; If client now has no pending buffers, | 368 ;; If client now has no pending buffers, |
377 ;; tell it that it is done, and forget it entirely. | 369 ;; tell it that it is done, and forget it entirely. |
378 (if (cdr client) nil | 370 (unless (cdr client) |
379 (if running | 371 (delete-process (car client)) |
380 (progn | 372 (server-log "Close" (car client)) |
381 ;; Don't send emacsserver two commands in close succession. | |
382 ;; It cannot handle that. | |
383 (or first (sit-for 1)) | |
384 (setq first nil) | |
385 (send-string server-process | |
386 (format "Close: %s Done\n" (car client))) | |
387 (server-log "Close" (car client)))) | |
388 (setq server-clients (delq client server-clients)))) | 373 (setq server-clients (delq client server-clients)))) |
389 (setq old-clients (cdr old-clients))) | 374 (setq old-clients (cdr old-clients))) |
390 (if (and (bufferp buffer) (buffer-name buffer)) | 375 (if (and (bufferp buffer) (buffer-name buffer)) |
391 ;; We may or may not kill this buffer; | 376 ;; We may or may not kill this buffer; |
392 ;; if we do, do not call server-buffer-done recursively | 377 ;; if we do, do not call server-buffer-done recursively |
517 ;; This means we should avoid the final "switch to some other buffer" | 502 ;; This means we should avoid the final "switch to some other buffer" |
518 ;; since we've already effectively done that. | 503 ;; since we've already effectively done that. |
519 (if (null next-buffer) | 504 (if (null next-buffer) |
520 (if server-clients | 505 (if server-clients |
521 (server-switch-buffer (nth 1 (car server-clients)) killed-one) | 506 (server-switch-buffer (nth 1 (car server-clients)) killed-one) |
522 (unless (or killed-one | 507 (unless (or killed-one (window-dedicated-p (selected-window))) |
523 (window-dedicated-p (selected-window))) | |
524 (switch-to-buffer (other-buffer)))) | 508 (switch-to-buffer (other-buffer)))) |
525 (if (not (buffer-name next-buffer)) | 509 (if (not (buffer-name next-buffer)) |
526 ;; If NEXT-BUFFER is a dead buffer, remove the server records for it | 510 ;; If NEXT-BUFFER is a dead buffer, remove the server records for it |
527 ;; and try the next surviving server buffer. | 511 ;; and try the next surviving server buffer. |
528 (apply 'server-switch-buffer (server-buffer-done next-buffer)) | 512 (apply 'server-switch-buffer (server-buffer-done next-buffer)) |
548 ;; Move to a non-dedicated window, if we have one. | 532 ;; Move to a non-dedicated window, if we have one. |
549 (when (window-dedicated-p (selected-window)) | 533 (when (window-dedicated-p (selected-window)) |
550 (select-window (get-window-with-predicate | 534 (select-window (get-window-with-predicate |
551 (lambda (w) (not (window-dedicated-p w))) | 535 (lambda (w) (not (window-dedicated-p w))) |
552 'nomini 'visible (selected-window)))) | 536 'nomini 'visible (selected-window)))) |
553 (set-window-dedicated-p (selected-window) nil) | 537 (condition-case nil |
554 (switch-to-buffer next-buffer)))))) | 538 (switch-to-buffer next-buffer) |
539 ;; After all the above, we might still have ended up with | |
540 ;; a minibuffer/dedicated-window (if there's no other). | |
541 (error (pop-to-buffer next-buffer)))))))) | |
555 | 542 |
556 (global-set-key "\C-x#" 'server-edit) | 543 (global-set-key "\C-x#" 'server-edit) |
557 | 544 |
558 (defun server-unload-hook () | 545 (defun server-unload-hook () |
559 (remove-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function) | 546 (remove-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function) |