update.
[chise/xemacs-chise.git-] / lisp / gnuserv.el
1 ;;; gnuserv.el --- Lisp interface code between Emacs and gnuserv
2 ;; Copyright (C) 1989-1997 Free Software Foundation, Inc.
3
4 ;; Version: 3.12
5 ;; Author: Andy Norman (ange@hplb.hpl.hp.com), originally based on server.el
6 ;;         Hrvoje Niksic <hniksic@xemacs.org>
7 ;; Maintainer: Jan Vroonhof <vroonhof@math.ethz.ch>,
8 ;;             Hrvoje Niksic <hniksic@xemacs.org>
9 ;; Keywords: environment, processes, terminals
10
11 ;; This file is part of XEmacs.
12
13 ;; XEmacs is free software; you can redistribute it and/or modify it
14 ;; under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; any later version.
17
18 ;; XEmacs is distributed in the hope that it will be useful, but
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21 ;; General Public License for more details.
22
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with XEmacs; see the file COPYING.  If not, write to the
25 ;; Free Software Foundation, 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA.
27
28 ;;; Synched up with: Not in FSF.
29
30 ;;; Commentary:
31
32 ;; Gnuserv is run when Emacs needs to operate as a server for other
33 ;; processes.  Specifically, any number of files can be attached for
34 ;; editing to a running XEmacs process using the `gnuclient' program.
35
36 ;; Use `M-x gnuserv-start' to start the server and `gnuclient files'
37 ;; to load them to XEmacs.  When you are done with a buffer, press
38 ;; `C-x #' (`M-x gnuserv-edit').  You can put (gnuserv-start) to your
39 ;; .emacs, and enable `gnuclient' as your Unix "editor".  When all the
40 ;; buffers for a client have been edited and exited with
41 ;; `gnuserv-edit', the client "editor" will return to the program that
42 ;; invoked it.
43
44 ;; Your editing commands and Emacs' display output go to and from the
45 ;; terminal or X display in the usual way.  If you are running under
46 ;; X, a new X frame will be open for each gnuclient.  If you are on a
47 ;; TTY, this TTY will be attached as a new device to the running
48 ;; XEmacs, and will be removed once you are done with the buffer.
49
50 ;; To evaluate a Lisp form in a running Emacs, use the `-eval'
51 ;; argument of gnuclient.  To simplify this, we provide the `gnudoit'
52 ;; shell script.  For example `gnudoit "(+ 2 3)"' will print `5',
53 ;; whereas `gnudoit "(gnus)"' will fire up your favorite newsreader.
54 ;; Like gnuclient, `gnudoit' requires the server to be started prior
55 ;; to using it.
56
57 ;; For more information you can refer to man pages of gnuclient,
58 ;; gnudoit and gnuserv, distributed with XEmacs.
59
60 ;; gnuserv.el was originally written by Andy Norman as an improvement
61 ;; over William Sommerfeld's server.el.  Since then, a number of
62 ;; people have worked on it, including Bob Weiner, Darell Kindred,
63 ;; Arup Mukherjee, Ben Wing and Jan Vroonhof.  It was completely
64 ;; rewritten (labeled as version 3) by Hrvoje Niksic in May 1997.  The
65 ;; new code will not run on GNU Emacs.
66
67 ;; Jan Vroonhof <vroonhof@math.ethz.ch> July/1996
68 ;; ported the server-temp-file-regexp feature from server.el
69 ;; ported server hooks from server.el
70 ;; ported kill-*-query functions from server.el (and made it optional)
71 ;; synced other behavior with server.el
72 ;;
73 ;; Jan Vroonhof
74 ;;     Customized.
75 ;;
76 ;; Hrvoje Niksic <hniksic@xemacs.org> May/1997
77 ;;     Completely rewritten.  Now uses `defstruct' and other CL stuff
78 ;;     to define clients cleanly.  Many thanks to Dave Gillespie!
79 ;;
80 ;; Mike Scheidler <c23mts@eng.delcoelect.com> July, 1997
81 ;;     Added 'Done' button to the menubar.
82
83 \f
84 ;;; Code:
85
86 (defgroup gnuserv nil
87   "The gnuserv suite of programs to talk to Emacs from outside."
88   :group 'environment
89   :group 'processes
90   :group 'terminals)
91
92 ;;;###autoload
93 (defcustom gnuserv-mode-line-string " Server"
94   "*String to display in the modeline when Gnuserv is active.
95 Set this to nil if you don't want a modeline indicator."
96 :type '(choice string
97                  (const :tag "none" nil))
98 :group 'gnuserv)
99
100
101 ;; Provide the old variables as aliases, to avoid breaking .emacs
102 ;; files.  However, they are obsolete and should be converted to the
103 ;; new forms.  This ugly crock must be before the variable
104 ;; declaration, or the scheme fails.
105
106 (define-obsolete-variable-alias 'server-frame 'gnuserv-frame)
107 (define-obsolete-variable-alias 'server-done-function
108   'gnuserv-done-function)
109 (define-obsolete-variable-alias 'server-done-temp-file-function
110   'gnuserv-done-temp-file-function)
111 (define-obsolete-variable-alias 'server-find-file-function
112   'gnuserv-find-file-function)
113 (define-obsolete-variable-alias 'server-program
114   'gnuserv-program)
115 (define-obsolete-variable-alias 'server-visit-hook
116   'gnuserv-visit-hook)
117 (define-obsolete-variable-alias 'server-done-hook
118   'gnuserv-done-hook)
119 (define-obsolete-variable-alias 'server-kill-quietly
120   'gnuserv-kill-quietly)
121 (define-obsolete-variable-alias 'server-temp-file-regexp
122   'gnuserv-temp-file-regexp)
123 (define-obsolete-variable-alias 'server-make-temp-file-backup
124   'gnuserv-make-temp-file-backup)
125
126 ;;;###autoload
127 (defcustom gnuserv-frame nil
128   "*The frame to be used to display all edited files.
129 If nil, then a new frame is created for each file edited.
130 If t, then the currently selected frame will be used.
131 If a function, then this will be called with a symbol `x' or `tty' as the
132 only argument, and its return value will be interpreted as above."
133   :tag "Gnuserv Frame"
134   :type '(radio (const :tag "Create new frame each time" nil)
135                 (const :tag "Use selected frame" t)
136                 (function-item :tag "Use main Emacs frame"
137                                gnuserv-main-frame-function)
138                 (function-item :tag "Use visible frame, otherwise create new"
139                                gnuserv-visible-frame-function)
140                 (function-item :tag "Create special Gnuserv frame and use it"
141                                gnuserv-special-frame-function)
142                 (function :tag "Other"))
143   :group 'gnuserv
144   :group 'frames)
145
146 (defcustom gnuserv-frame-plist nil
147   "*Plist of frame properties for creating a gnuserv frame."
148   :type 'plist
149   :group 'gnuserv
150   :group 'frames)
151
152 (defcustom gnuserv-done-function 'kill-buffer
153   "*Function used to remove a buffer after editing.
154 It is called with one BUFFER argument.  Functions such as `kill-buffer' and
155 `bury-buffer' are good values. See also `gnuserv-done-temp-file-function'."
156   :type '(radio (function-item kill-buffer)
157                 (function-item bury-buffer)
158                 (function :tag "Other"))
159   :group 'gnuserv)
160
161 (defcustom gnuserv-done-temp-file-function 'kill-buffer
162   "*Function used to remove a temporary buffer after editing.
163 It is called with one BUFFER argument.  Functions such as `kill-buffer' and
164 `bury-buffer' are good values. See also `gnuserv-done-temp-file-function'."
165   :type '(radio (function-item kill-buffer)
166                 (function-item bury-buffer)
167                 (function :tag "Other"))
168   :group 'gnuserv)
169
170 (defcustom gnuserv-find-file-function 'find-file
171   "*Function to visit a file with.
172 It takes one argument, a file name to visit."
173   :type 'function
174   :group 'gnuserv)
175
176 (defcustom gnuserv-view-file-function 'view-file
177   "*Function to view a file with.
178 It takes one argument, a file name to view."
179   :type '(radio (function-item view-file)
180                 (function-item find-file-read-only)
181                 (function :tag "Other"))
182   :group 'gnuserv)
183
184 (defcustom gnuserv-program "gnuserv"
185   "*Program to use as the editing server."
186   :type 'string
187   :group 'gnuserv)
188
189 (defcustom gnuserv-visit-hook nil
190   "*Hook run after visiting a file."
191   :type 'hook
192   :group 'gnuserv)
193
194 (defcustom gnuserv-done-hook nil
195   "*Hook run when done editing a buffer for the Emacs server.
196 The hook functions are called after the file has been visited, with the
197 current buffer set to the visiting buffer."
198   :type 'hook
199   :group 'gnuserv)
200
201 (defcustom gnuserv-init-hook nil
202   "*Hook run after the server is started."
203   :type 'hook
204   :group 'gnuserv)
205
206 (defcustom gnuserv-shutdown-hook nil
207   "*Hook run before the server exits."
208   :type 'hook
209   :group 'gnuserv)
210
211 (defcustom gnuserv-kill-quietly nil
212   "*Non-nil means to kill buffers with clients attached without requiring confirmation."
213   :type 'boolean
214   :group 'gnuserv)
215
216 (defcustom gnuserv-temp-file-regexp
217   (concat "^" (temp-directory) "/Re\\|/draft$")
218   "*Regexp which should match filenames of temporary files deleted
219 and reused by the programs that invoke the Emacs server."
220   :type 'regexp
221   :group 'gnuserv)
222
223 (defcustom gnuserv-make-temp-file-backup nil
224   "*Non-nil makes the server backup temporary files also."
225   :type 'boolean
226   :group 'gnuserv)
227
228 \f
229 ;;; Internal variables:
230
231 (defstruct gnuclient
232   "An object that encompasses several buffers in one.
233 Normally, a client connecting to Emacs will be assigned an id, and
234 will request editing of several files.
235
236 ID       - Client id (integer).
237 BUFFERS  - List of buffers that \"belong\" to the client.
238            NOTE: one buffer can belong to several clients.
239 DEVICE   - The device this client is on.  If the device was also created.
240            by a client, it will be placed to `gnuserv-devices' list.
241 FRAME    - Frame created by the client, or nil if the client didn't
242            create a frame.
243
244 All the slots default to nil."
245   (id nil)
246   (buffers nil)
247   (device nil)
248   (frame nil))
249
250 (defvar gnuserv-process nil
251   "The current gnuserv process.")
252
253 (defvar gnuserv-string ""
254   "The last input string from the server.")
255
256 (defvar gnuserv-current-client nil
257   "The client we are currently talking to.")
258
259 (defvar gnuserv-clients nil
260   "List of current gnuserv clients.
261 Each element is a gnuclient structure that identifies a client.")
262
263 (defvar gnuserv-devices nil
264   "List of devices created by clients.")
265
266 (defvar gnuserv-special-frame nil
267   "Frame created specially for Server.")
268
269 ;; We want the client-infested buffers to have some modeline
270 ;; identification, so we'll make a "minor mode".
271 (defvar gnuserv-minor-mode nil)
272 (make-variable-buffer-local 'gnuserv-minor-mode)
273 ;;(pushnew '(gnuserv-minor-mode "Server") minor-mode-alist
274 ;;       :test 'equal)
275 (add-minor-mode 'gnuserv-minor-mode 'gnuserv-mode-line-string)
276
277 \f
278 ;; Sample gnuserv-frame functions
279
280 (defun gnuserv-main-frame-function (type)
281   "Return a sensible value for the main Emacs frame."
282   (if (or (eq type 'x)
283           (eq type 'gtk)
284           (eq type 'mswindows))
285       (car (frame-list))
286     nil))
287
288 (defun gnuserv-visible-frame-function (type)
289   "Return a frame if there is a frame that is truly visible, nil otherwise.
290 This is meant in the X sense, so it will not return frames that are on another
291 visual screen.  Totally visible frames are preferred.  If none found, return nil."
292   (if (or (eq type 'x)
293           (eq type 'gtk)
294           (eq type 'mswindows))
295       (cond ((car (filtered-frame-list 'frame-totally-visible-p
296                                        (selected-device))))
297             ((car (filtered-frame-list (lambda (frame)
298                                          ;; eq t as in not 'hidden
299                                          (eq t (frame-visible-p frame)))
300                                        (selected-device)))))
301     nil))
302
303 (defun gnuserv-special-frame-function (type)
304   "Create a special frame for Gnuserv and return it on later invocations."
305   (unless (frame-live-p gnuserv-special-frame)
306     (setq gnuserv-special-frame (make-frame gnuserv-frame-plist)))
307   gnuserv-special-frame)
308
309 \f
310 ;;; Communication functions
311
312 ;; We used to restart the server here, but it's too risky -- if
313 ;; something goes awry, it's too easy to wind up in a loop.
314 (defun gnuserv-sentinel (proc msg)
315   (let ((msgstring (concat "Gnuserv process %s; restart with `%s'"))
316         (keystring (substitute-command-keys "\\[gnuserv-start]")))
317   (case (process-status proc)
318     (exit
319      (message msgstring "exited" keystring)
320      (gnuserv-prepare-shutdown))
321     (signal
322      (message msgstring "killed" keystring)
323      (gnuserv-prepare-shutdown))
324     (closed
325      (message msgstring "closed" keystring))
326      (gnuserv-prepare-shutdown))))
327
328 ;; This function reads client requests from our current server.  Every
329 ;; client is identified by a unique ID within the server
330 ;; (incidentally, the same ID is the file descriptor the server uses
331 ;; to communicate to client).
332 ;;
333 ;; The request string can arrive in several chunks.  As the request
334 ;; ends with \C-d, we check for that character at the end of string.
335 ;; If not found, keep reading, and concatenating to former strings.
336 ;; So, if at first read we receive "5 (gn", that text will be stored
337 ;; to gnuserv-string.  If we then receive "us)\C-d", the two will be
338 ;; concatenated, `current-client' will be set to 5, and `(gnus)' form
339 ;; will be evaluated.
340 ;;
341 ;; Server will send the following:
342 ;;
343 ;; "ID <text>\C-d"  (no quotes)
344 ;;
345 ;;  ID    - file descriptor of the given client;
346 ;; <text> - the actual contents of the request.
347 (defun gnuserv-process-filter (proc string)
348   "Process gnuserv client requests to execute Emacs commands."
349   (setq gnuserv-string (concat gnuserv-string string))
350   ;; C-d means end of request.
351   (when (string-match "\C-d\n?\\'" gnuserv-string)
352     (cond ((string-match "\\`[0-9]+" gnuserv-string) ; client request id
353            (let ((header (read-from-string gnuserv-string)))
354              ;; Set the client we are talking to.
355              (setq gnuserv-current-client (car header))
356              ;; Evaluate the expression
357              (condition-case oops
358                  (eval (car (read-from-string gnuserv-string (cdr header))))
359                ;; In case of an error, write the description to the
360                ;; client, and then signal it.
361                (error (setq gnuserv-string "")
362                       (when gnuserv-current-client
363                         (gnuserv-write-to-client gnuserv-current-client oops))
364                       (setq gnuserv-current-client nil)
365                       (signal (car oops) (cdr oops)))
366                (quit (setq gnuserv-string "")
367                      (when gnuserv-current-client
368                        (gnuserv-write-to-client gnuserv-current-client oops))
369                      (setq gnuserv-current-client nil)
370                      (signal 'quit nil)))
371              (setq gnuserv-string "")))
372           (t
373            (let ((response (car (split-string gnuserv-string "\C-d"))))
374              (setq gnuserv-string "")
375              (error "%s: invalid response from gnuserv" response))))))
376
377 ;; This function is somewhat of a misnomer.  Actually, we write to the
378 ;; server (using `process-send-string' to gnuserv-process), which
379 ;; interprets what we say and forwards it to the client.  The
380 ;; incantation server understands is (from gnuserv.c):
381 ;;
382 ;; "FD/LEN:<text>\n"  (no quotes)
383 ;;    FD     - file descriptor of the given client (which we obtained from
384 ;;             the server earlier);
385 ;;    LEN    - length of the stuff we are about to send;
386 ;;    <text> - the actual contents of the request.
387 (defun gnuserv-write-to-client (client-id form)
388   "Write the given form to the given client via the gnuserv process."
389   (when (eq (process-status gnuserv-process) 'run)
390     (let* ((result (format "%s" form))
391            (s      (format "%s/%d:%s\n" client-id
392                            (length result) result)))
393       (process-send-string gnuserv-process s))))
394
395 ;; The following two functions are helper functions, used by
396 ;; gnuclient.
397
398 (defun gnuserv-eval (form)
399   "Evaluate form and return result to client."
400   (gnuserv-write-to-client gnuserv-current-client (eval form))
401   (setq gnuserv-current-client nil))
402
403 (defun gnuserv-eval-quickly (form)
404   "Let client know that we've received the request, and then eval the form.
405 This order is important as not to keep the client waiting."
406   (gnuserv-write-to-client gnuserv-current-client nil)
407   (setq gnuserv-current-client nil)
408   (eval form))
409
410 \f
411
412 (defun make-x-device-with-gtk-fallback (device)
413   (or (condition-case ()
414           (make-x-device device)
415         (error nil))
416       (make-gtk-device)))
417
418 ;; "Execute" a client connection, called by gnuclient.  This is the
419 ;; backbone of gnuserv.el.
420 (defun gnuserv-edit-files (type list &rest flags)
421   "For each (line-number . file) pair in LIST, edit the file at line-number.
422 The visited buffers are memorized, so that when \\[gnuserv-edit] is invoked
423 in such a buffer, or when it is killed, or the client's device deleted, the
424 client will be invoked that the edit is finished.
425
426 TYPE should either be a (tty TTY TERM PID) list, or (x DISPLAY) list.
427 If a flag is `quick', just edit the files in Emacs.
428 If a flag is `view', view the files read-only."
429   (let (quick view)
430     (mapc (lambda (flag)
431             (case flag
432               (quick (setq quick t))
433               (view  (setq view t))
434               (t     (error "Invalid flag %s" flag))))
435           flags)
436     (let* ((old-device-num (length (device-list)))
437            (new-frame nil)
438            (dest-frame (if (functionp gnuserv-frame)
439                            (funcall gnuserv-frame (car type))
440                          gnuserv-frame))
441            ;; The gnuserv-frame dependencies are ugly, but it's
442            ;; extremely hard to make that stuff cleaner without
443            ;; breaking everything in sight.
444            (device (cond ((frame-live-p dest-frame)
445                           (frame-device dest-frame))
446                          ((null dest-frame)
447                           (case (car type)
448                             (tty (apply 'make-tty-device (cdr type)))
449                             (gtk (make-gtk-device))
450                             (x   (make-x-device-with-gtk-fallback (cadr type)))
451                             (mswindows   (make-mswindows-device))
452                             (t   (error "Invalid device type"))))
453                          (t
454                           (selected-device))))
455            (frame (cond ((frame-live-p dest-frame)
456                          dest-frame)
457                         ((null dest-frame)
458                          (setq new-frame (make-frame gnuserv-frame-plist
459                                                      device))
460                          new-frame)
461                         (t (selected-frame))))
462            (client (make-gnuclient :id gnuserv-current-client
463                                    :device device
464                                    :frame new-frame)))
465       (select-frame frame)
466       (setq gnuserv-current-client nil)
467       ;; If the device was created by this client, push it to the list.
468       (and (/= old-device-num (length (device-list)))
469            (push device gnuserv-devices))
470       (and (frame-iconified-p frame)
471            (deiconify-frame frame))
472       ;; Visit all the listed files.
473       (while list
474         (let ((line (caar list)) (path (cdar list)))
475           (select-frame frame)
476           ;; Visit the file.
477           (funcall (if view
478                        gnuserv-view-file-function
479                      gnuserv-find-file-function)
480                    path)
481           (goto-line line)
482           ;; Don't memorize the quick and view buffers.
483           (unless (or quick view)
484             (pushnew (current-buffer) (gnuclient-buffers client))
485             (setq gnuserv-minor-mode t)
486             ;; Add the "Done" button to the menubar, only in this buffer.
487             (if (and (featurep 'menubar) current-menubar)
488               (progn (set-buffer-menubar current-menubar)
489               (add-menu-button nil ["Done" gnuserv-edit]))
490               ))
491           (run-hooks 'gnuserv-visit-hook)
492           (pop list)))
493       (cond
494        ((and (or quick view)
495              (device-on-window-system-p device))
496         ;; Exit if on X device, and quick or view.  NOTE: if the
497         ;; client is to finish now, it must absolutely /not/ be
498         ;; included to the list of clients.  This way the client-ids
499         ;; should be unique.
500         (gnuserv-write-to-client (gnuclient-id client) nil))
501        (t
502         ;; Else, the client gets a vote.
503         (push client gnuserv-clients)
504         ;; Explain buffer exit options.  If dest-frame is nil, the
505         ;; user can exit via `delete-frame'.  OTOH, if FLAGS are nil
506         ;; and there are some buffers, the user can exit via
507         ;; `gnuserv-edit'.
508         (if (and (not (or quick view))
509                  (gnuclient-buffers client))
510             (message "%s"
511                      (substitute-command-keys
512                       "Type `\\[gnuserv-edit]' to finish editing"))
513           (or dest-frame
514               (message "%s"
515                        (substitute-command-keys
516                         "Type `\\[delete-frame]' to finish editing")))))))))
517
518 \f
519 ;;; Functions that hook into Emacs in various way to enable operation
520
521 ;; Defined later.
522 (add-hook 'kill-emacs-hook 'gnuserv-kill-all-clients t)
523
524 ;; A helper function; used by others.  Try avoiding it whenever
525 ;; possible, because it is slow, and conses a list.  Use
526 ;; `gnuserv-buffer-p' when appropriate, for instance.
527 (defun gnuserv-buffer-clients (buffer)
528   "Return a list of clients to which BUFFER belongs."
529   (let (res)
530     (dolist (client gnuserv-clients)
531       (when (memq buffer (gnuclient-buffers client))
532         (push client res)))
533     res))
534
535 ;; Like `gnuserv-buffer-clients', but returns a boolean; doesn't
536 ;; collect a list.
537 (defun gnuserv-buffer-p (buffer)
538   (member* buffer gnuserv-clients
539            :test 'memq
540            :key 'gnuclient-buffers))
541
542 ;; This function makes sure that a killed buffer is deleted off the
543 ;; list for the particular client.
544 ;;
545 ;; This hooks into `kill-buffer-hook'.  It is *not* a replacement for
546 ;; `kill-buffer' (thanks God).
547 (defun gnuserv-kill-buffer-function ()
548   "Remove the buffer from the buffer lists of all the clients it belongs to.
549 Any client that remains \"empty\" after the removal is informed that the
550 editing has ended."
551   (let* ((buf (current-buffer)))
552     (dolist (client (gnuserv-buffer-clients buf))
553       (callf2 delq buf (gnuclient-buffers client))
554       ;; If no more buffers, kill the client.
555       (when (null (gnuclient-buffers client))
556         (gnuserv-kill-client client)))))
557
558 (add-hook 'kill-buffer-hook 'gnuserv-kill-buffer-function)
559
560 ;; Ask for confirmation before killing a buffer that belongs to a
561 ;; living client.
562 (defun gnuserv-kill-buffer-query-function ()
563   (or gnuserv-kill-quietly
564       (not (gnuserv-buffer-p (current-buffer)))
565       (yes-or-no-p
566        (format "Buffer %s belongs to gnuserv client(s); kill anyway? "
567                (current-buffer)))))
568
569 (add-hook 'kill-buffer-query-functions
570           'gnuserv-kill-buffer-query-function)
571
572 (defun gnuserv-kill-emacs-query-function ()
573   (or gnuserv-kill-quietly
574       (not (some 'gnuclient-buffers gnuserv-clients))
575       (yes-or-no-p "Gnuserv buffers still have clients; exit anyway? ")))
576
577 (add-hook 'kill-emacs-query-functions
578           'gnuserv-kill-emacs-query-function)
579
580 ;; If the device of a client is to be deleted, the client should die
581 ;; as well.  This is why we hook into `delete-device-hook'.
582 (defun gnuserv-check-device (device)
583   (when (memq device gnuserv-devices)
584     (dolist (client gnuserv-clients)
585       (when (eq device (gnuclient-device client))
586         ;; we must make sure that the server kill doesn't result in
587         ;; killing the device, because it would cause a device-dead
588         ;; error when `delete-device' tries to do the job later.
589         (gnuserv-kill-client client t))))
590   (callf2 delq device gnuserv-devices))
591
592 (add-hook 'delete-device-hook 'gnuserv-check-device)
593
594 (defun gnuserv-temp-file-p (buffer)
595   "Return non-nil if BUFFER contains a file considered temporary.
596 These are files whose names suggest they are repeatedly
597 reused to pass information to another program.
598
599 The variable `gnuserv-temp-file-regexp' controls which filenames
600 are considered temporary."
601   (and (buffer-file-name buffer)
602        (string-match gnuserv-temp-file-regexp (buffer-file-name buffer))))
603
604 (defun gnuserv-kill-client (client &optional leave-frame)
605   "Kill the gnuclient CLIENT.
606 This will do away with all the associated buffers.  If LEAVE-FRAME,
607 the function will not remove the frames associated with the client."
608   ;; Order is important: first delete client from gnuserv-clients, to
609   ;; prevent gnuserv-buffer-done-1 calling us recursively.
610   (callf2 delq client gnuserv-clients)
611   ;; Process the buffers.
612   (mapc 'gnuserv-buffer-done-1 (gnuclient-buffers client))
613   (unless leave-frame
614     (let ((device (gnuclient-device client)))
615       ;; kill frame created by this client (if any), unless
616       ;; specifically requested otherwise.
617       ;;
618       ;; note: last frame on a device will not be deleted here.
619     (when (and (gnuclient-frame client)
620                (frame-live-p (gnuclient-frame client))
621                (second (device-frame-list device)))
622       (delete-frame (gnuclient-frame client)))
623     ;; If the device is live, created by a client, and no longer used
624     ;; by any client, delete it.
625     (when (and (device-live-p device)
626                (memq device gnuserv-devices)
627                (second (device-list))
628                (not (member* device gnuserv-clients
629                              :key 'gnuclient-device)))
630       ;; `gnuserv-check-device' will remove it from `gnuserv-devices'.
631       (delete-device device))))
632   ;; Notify the client.
633   (gnuserv-write-to-client (gnuclient-id client) nil))
634
635 ;; Do away with the buffer.
636 (defun gnuserv-buffer-done-1 (buffer)
637   (dolist (client (gnuserv-buffer-clients buffer))
638     (callf2 delq buffer (gnuclient-buffers client))
639     (when (null (gnuclient-buffers client))
640       (gnuserv-kill-client client)))
641   ;; Get rid of the buffer.
642   (save-excursion
643     (set-buffer buffer)
644     (run-hooks 'gnuserv-done-hook)
645     (setq gnuserv-minor-mode nil)
646     ;; Delete the menu button.
647     (if (and (featurep 'menubar) current-menubar)
648       (delete-menu-item '("Done")))
649     (funcall (if (gnuserv-temp-file-p buffer)
650                  gnuserv-done-temp-file-function
651                gnuserv-done-function)
652              buffer)))
653
654 \f
655 ;;; Higher-level functions
656
657 ;; Choose a `next' server buffer, according to several criteria, and
658 ;; return it.  If none are found, return nil.
659 (defun gnuserv-next-buffer ()
660   (let* ((frame (selected-frame))
661          (device (selected-device))
662          client)
663     (cond
664      ;; If we have a client belonging to this frame, return
665      ;; the first buffer from it.
666      ((setq client
667             (car (member* frame gnuserv-clients :key 'gnuclient-frame)))
668       (car (gnuclient-buffers client)))
669      ;; Else, look for a device.
670      ((and
671        (memq (selected-device) gnuserv-devices)
672        (setq client
673              (car (member* device gnuserv-clients :key 'gnuclient-device))))
674       (car (gnuclient-buffers client)))
675      ;; Else, try to find any client with at least one buffer, and
676      ;; return its first buffer.
677      ((setq client
678             (car (member-if-not #'null gnuserv-clients
679                                 :key 'gnuclient-buffers)))
680       (car (gnuclient-buffers client)))
681      ;; Oh, give up.
682      (t nil))))
683
684 (defun gnuserv-buffer-done (buffer)
685   "Mark BUFFER as \"done\" for its client(s).
686 Does the save/backup queries first, and calls `gnuserv-done-function'."
687   ;; Check whether this is the real thing.
688   (unless (gnuserv-buffer-p buffer)
689     (error "%s does not belong to a gnuserv client" buffer))
690   ;; Backup/ask query.
691   (if (gnuserv-temp-file-p buffer)
692       ;; For a temp file, save, and do NOT make a non-numeric backup
693       ;; Why does server.el explicitly back up temporary files?
694       (let ((version-control nil)
695             (buffer-backed-up (not gnuserv-make-temp-file-backup)))
696         (save-buffer))
697     (if (and (buffer-modified-p)
698              (y-or-n-p (concat "Save file " buffer-file-name "? ")))
699         (save-buffer buffer)))
700   (gnuserv-buffer-done-1 buffer))
701
702 ;; Called by `gnuserv-start-1' to clean everything.  Hooked into
703 ;; `kill-emacs-hook', too.
704 (defun gnuserv-kill-all-clients ()
705   "Kill all the gnuserv clients.  Ruthlessly."
706   (mapc 'gnuserv-kill-client gnuserv-clients))
707
708 ;; This serves to run the hook and reset
709 ;; `allow-deletion-of-last-visible-frame'.
710 (defun gnuserv-prepare-shutdown ()
711   (setq allow-deletion-of-last-visible-frame nil)
712   (run-hooks 'gnuserv-shutdown-hook))
713
714 ;; This is a user-callable function, too.
715 (defun gnuserv-shutdown ()
716   "Shutdown the gnuserv server, if one is currently running.
717 All the clients will be disposed of via the normal methods."
718   (interactive)
719   (gnuserv-kill-all-clients)
720   (when gnuserv-process
721     (set-process-sentinel gnuserv-process nil)
722     (gnuserv-prepare-shutdown)
723     (condition-case ()
724         (delete-process gnuserv-process)
725       (error nil))
726     (setq gnuserv-process nil)))
727
728 ;; Actually start the process.  Kills all the clients before-hand.
729 (defun gnuserv-start-1 (&optional leave-dead)
730   ;; Shutdown the existing server, if any.
731   (gnuserv-shutdown)
732   ;; If we already had a server, clear out associated status.
733   (unless leave-dead
734     (setq gnuserv-string ""
735           gnuserv-current-client nil)
736     (let ((process-connection-type t))
737       (setq gnuserv-process
738             (start-process "gnuserv" nil gnuserv-program)))
739     (set-process-sentinel gnuserv-process 'gnuserv-sentinel)
740     (set-process-filter gnuserv-process 'gnuserv-process-filter)
741     (process-kill-without-query gnuserv-process)
742     (setq allow-deletion-of-last-visible-frame t)
743     (run-hooks 'gnuserv-init-hook)))
744
745 \f
746 ;;; User-callable functions:
747
748 ;;;###autoload
749 (defun gnuserv-running-p ()
750   "Return non-nil if a gnuserv process is running from this XEmacs session."
751   (not (not gnuserv-process)))
752
753 ;;;###autoload
754 (defun gnuserv-start (&optional leave-dead)
755   "Allow this Emacs process to be a server for client processes.
756 This starts a gnuserv communications subprocess through which
757 client \"editors\" (gnuclient and gnudoit) can send editing commands to
758 this Emacs job.  See the gnuserv(1) manual page for more details.
759
760 Prefix arg means just kill any existing server communications subprocess."
761   (interactive "P")
762   (and gnuserv-process
763        (not leave-dead)
764        (message "Restarting gnuserv"))
765   (gnuserv-start-1 leave-dead))
766
767 (defun gnuserv-edit (&optional count)
768   "Mark the current gnuserv editing buffer as \"done\", and switch to next one.
769
770 Run with a numeric prefix argument, repeat the operation that number
771 of times.  If given a universal prefix argument, close all the buffers
772 of this buffer's clients.
773
774 The `gnuserv-done-function' (bound to `kill-buffer' by default) is
775 called to dispose of the buffer after marking it as done.
776
777 Files that match `gnuserv-temp-file-regexp' are considered temporary and
778 are saved unconditionally and backed up if `gnuserv-make-temp-file-backup'
779 is non-nil.  They are disposed of using `gnuserv-done-temp-file-function'
780 \(also bound to `kill-buffer' by default).
781
782 When all of a client's buffers are marked as \"done\", the client is notified."
783   (interactive "P")
784   (when (null count)
785     (setq count 1))
786   (cond ((numberp count)
787          (while (natnump (decf count))
788            (let ((frame (selected-frame)))
789              (gnuserv-buffer-done (current-buffer))
790              (when (eq frame (selected-frame))
791                ;; Switch to the next gnuserv buffer.  However, do this
792                ;; only if we remain in the same frame.
793                (let ((next (gnuserv-next-buffer)))
794                  (when next
795                    (switch-to-buffer next)))))))
796         (count
797            (let* ((buf (current-buffer))
798                   (clients (gnuserv-buffer-clients buf)))
799              (unless clients
800                (error "%s does not belong to a gnuserv client" buf))
801              (mapc 'gnuserv-kill-client (gnuserv-buffer-clients buf))))))
802
803 (global-set-key "\C-x#" 'gnuserv-edit)
804
805 (provide 'gnuserv)
806
807 ;;; gnuserv.el ends here