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