Mercurial > hg > xemacs-beta
annotate lisp/gnuserv.el @ 4482:e3ef34f57070
Bind function-key-map correctly in device-specific startup code.
2008-07-26 Aidan Kehoe <kehoea@parhasard.net>
* x-init.el (x-initialize-compose):
Rewrite to use #'loop, as does similar code in x-win-sun.el,
x-win-xfree86.el. Locally bind function-key-map to the correct
value for the device's console.
* x-win-xfree86.el (x-win-init-xfree86):
Locally bind function-key-map to the correct value for the
device's console.
* x-win-sun.el (x-win-init-sun):
Locally bind function-key-map to the correct value for the
device's console.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 26 Jul 2008 09:37:08 +0200 |
| parents | a72dc882abf1 |
| children | 15c42a3f4065 |
| rev | line source |
|---|---|
| 428 | 1 ;;; gnuserv.el --- Lisp interface code between Emacs and gnuserv |
| 2 ;; Copyright (C) 1989-1997 Free Software Foundation, Inc. | |
| 3 | |
| 456 | 4 ;; Version: 3.12 |
| 428 | 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 | |
| 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 | |
| 710 | 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 | |
| 428 | 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 | |
|
4436
a72dc882abf1
Quote temp-directory regexp in gnuserv.
Mike Sperber <sperber@deinprogramm.de>
parents:
2437
diff
changeset
|
217 (concat "^" (regexp-quote (temp-directory)) "/Re\\|/draft$") |
| 428 | 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 | |
| 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) | |
| 710 | 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) | |
| 428 | 276 |
| 277 | |
| 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) | |
| 462 | 283 (eq type 'gtk) |
| 428 | 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) | |
| 462 | 293 (eq type 'gtk) |
| 428 | 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 | |
| 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. | |
| 456 | 351 (when (string-match "\C-d\n?\\'" gnuserv-string) |
| 352 (cond ((string-match "\\`[0-9]+" gnuserv-string) ; client request id | |
| 428 | 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 "") | |
| 434 | 362 (when gnuserv-current-client |
| 363 (gnuserv-write-to-client gnuserv-current-client oops)) | |
| 428 | 364 (setq gnuserv-current-client nil) |
| 365 (signal (car oops) (cdr oops))) | |
| 366 (quit (setq gnuserv-string "") | |
| 434 | 367 (when gnuserv-current-client |
| 368 (gnuserv-write-to-client gnuserv-current-client oops)) | |
| 428 | 369 (setq gnuserv-current-client nil) |
| 370 (signal 'quit nil))) | |
| 371 (setq gnuserv-string ""))) | |
| 372 (t | |
| 456 | 373 (let ((response (car (split-string gnuserv-string "\C-d")))) |
| 374 (setq gnuserv-string "") | |
| 375 (error "%s: invalid response from gnuserv" response)))))) | |
| 428 | 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 | |
| 1700 | 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 | |
| 428 | 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. | |
| 2437 | 422 The visited buffers are recorded, so that when \\[gnuserv-edit] is invoked |
| 428 | 423 in such a buffer, or when it is killed, or the client's device deleted, the |
| 2437 | 424 client will be informed that the edit is finished. |
| 428 | 425 |
| 2437 | 426 TYPE should be a list in one of the forms (tty TTY TERM PID), (x DISPLAY), |
| 427 \(gtk DISPLAY), or (mswindows DISPLAY). Currently GTK and MS Windows do not | |
| 428 support multiple displays, so the DISPLAY member is ignored. Conventionally | |
| 429 it is set to nil. | |
| 428 | 430 If a flag is `quick', just edit the files in Emacs. |
| 431 If a flag is `view', view the files read-only." | |
| 432 (let (quick view) | |
| 433 (mapc (lambda (flag) | |
| 434 (case flag | |
| 435 (quick (setq quick t)) | |
| 436 (view (setq view t)) | |
| 437 (t (error "Invalid flag %s" flag)))) | |
| 438 flags) | |
| 439 (let* ((old-device-num (length (device-list))) | |
| 440 (new-frame nil) | |
| 441 (dest-frame (if (functionp gnuserv-frame) | |
| 442 (funcall gnuserv-frame (car type)) | |
| 443 gnuserv-frame)) | |
| 444 ;; The gnuserv-frame dependencies are ugly, but it's | |
| 445 ;; extremely hard to make that stuff cleaner without | |
| 446 ;; breaking everything in sight. | |
| 447 (device (cond ((frame-live-p dest-frame) | |
| 448 (frame-device dest-frame)) | |
| 449 ((null dest-frame) | |
| 450 (case (car type) | |
| 451 (tty (apply 'make-tty-device (cdr type))) | |
| 462 | 452 (gtk (make-gtk-device)) |
| 1700 | 453 (x (make-x-device-with-gtk-fallback (cadr type))) |
| 428 | 454 (mswindows (make-mswindows-device)) |
| 455 (t (error "Invalid device type")))) | |
| 456 (t | |
| 457 (selected-device)))) | |
| 458 (frame (cond ((frame-live-p dest-frame) | |
| 459 dest-frame) | |
| 460 ((null dest-frame) | |
| 461 (setq new-frame (make-frame gnuserv-frame-plist | |
| 462 device)) | |
| 463 new-frame) | |
| 464 (t (selected-frame)))) | |
| 465 (client (make-gnuclient :id gnuserv-current-client | |
| 466 :device device | |
| 467 :frame new-frame))) | |
| 468 (select-frame frame) | |
| 469 (setq gnuserv-current-client nil) | |
| 470 ;; If the device was created by this client, push it to the list. | |
| 471 (and (/= old-device-num (length (device-list))) | |
| 472 (push device gnuserv-devices)) | |
| 473 (and (frame-iconified-p frame) | |
| 474 (deiconify-frame frame)) | |
| 475 ;; Visit all the listed files. | |
| 476 (while list | |
| 477 (let ((line (caar list)) (path (cdar list))) | |
| 478 (select-frame frame) | |
| 479 ;; Visit the file. | |
| 480 (funcall (if view | |
| 481 gnuserv-view-file-function | |
| 482 gnuserv-find-file-function) | |
| 483 path) | |
| 484 (goto-line line) | |
| 485 ;; Don't memorize the quick and view buffers. | |
| 486 (unless (or quick view) | |
| 487 (pushnew (current-buffer) (gnuclient-buffers client)) | |
| 488 (setq gnuserv-minor-mode t) | |
| 489 ;; Add the "Done" button to the menubar, only in this buffer. | |
| 490 (if (and (featurep 'menubar) current-menubar) | |
| 491 (progn (set-buffer-menubar current-menubar) | |
| 492 (add-menu-button nil ["Done" gnuserv-edit])) | |
| 493 )) | |
| 494 (run-hooks 'gnuserv-visit-hook) | |
| 495 (pop list))) | |
| 496 (cond | |
| 497 ((and (or quick view) | |
| 498 (device-on-window-system-p device)) | |
| 499 ;; Exit if on X device, and quick or view. NOTE: if the | |
| 500 ;; client is to finish now, it must absolutely /not/ be | |
| 501 ;; included to the list of clients. This way the client-ids | |
| 502 ;; should be unique. | |
| 503 (gnuserv-write-to-client (gnuclient-id client) nil)) | |
| 504 (t | |
| 505 ;; Else, the client gets a vote. | |
| 506 (push client gnuserv-clients) | |
| 507 ;; Explain buffer exit options. If dest-frame is nil, the | |
| 508 ;; user can exit via `delete-frame'. OTOH, if FLAGS are nil | |
| 509 ;; and there are some buffers, the user can exit via | |
| 510 ;; `gnuserv-edit'. | |
| 511 (if (and (not (or quick view)) | |
| 512 (gnuclient-buffers client)) | |
| 513 (message "%s" | |
| 514 (substitute-command-keys | |
| 515 "Type `\\[gnuserv-edit]' to finish editing")) | |
| 516 (or dest-frame | |
| 517 (message "%s" | |
| 518 (substitute-command-keys | |
| 519 "Type `\\[delete-frame]' to finish editing"))))))))) | |
| 520 | |
| 521 | |
| 522 ;;; Functions that hook into Emacs in various way to enable operation | |
| 523 | |
| 524 ;; Defined later. | |
| 525 (add-hook 'kill-emacs-hook 'gnuserv-kill-all-clients t) | |
| 526 | |
| 527 ;; A helper function; used by others. Try avoiding it whenever | |
| 528 ;; possible, because it is slow, and conses a list. Use | |
| 529 ;; `gnuserv-buffer-p' when appropriate, for instance. | |
| 530 (defun gnuserv-buffer-clients (buffer) | |
| 531 "Return a list of clients to which BUFFER belongs." | |
| 532 (let (res) | |
| 533 (dolist (client gnuserv-clients) | |
| 534 (when (memq buffer (gnuclient-buffers client)) | |
| 535 (push client res))) | |
| 536 res)) | |
| 537 | |
| 538 ;; Like `gnuserv-buffer-clients', but returns a boolean; doesn't | |
| 539 ;; collect a list. | |
| 540 (defun gnuserv-buffer-p (buffer) | |
| 541 (member* buffer gnuserv-clients | |
| 542 :test 'memq | |
| 543 :key 'gnuclient-buffers)) | |
| 544 | |
| 545 ;; This function makes sure that a killed buffer is deleted off the | |
| 546 ;; list for the particular client. | |
| 547 ;; | |
| 548 ;; This hooks into `kill-buffer-hook'. It is *not* a replacement for | |
| 549 ;; `kill-buffer' (thanks God). | |
| 550 (defun gnuserv-kill-buffer-function () | |
| 551 "Remove the buffer from the buffer lists of all the clients it belongs to. | |
| 552 Any client that remains \"empty\" after the removal is informed that the | |
| 553 editing has ended." | |
| 554 (let* ((buf (current-buffer))) | |
| 555 (dolist (client (gnuserv-buffer-clients buf)) | |
| 556 (callf2 delq buf (gnuclient-buffers client)) | |
| 557 ;; If no more buffers, kill the client. | |
| 558 (when (null (gnuclient-buffers client)) | |
| 559 (gnuserv-kill-client client))))) | |
| 560 | |
| 561 (add-hook 'kill-buffer-hook 'gnuserv-kill-buffer-function) | |
| 562 | |
| 563 ;; Ask for confirmation before killing a buffer that belongs to a | |
| 564 ;; living client. | |
| 565 (defun gnuserv-kill-buffer-query-function () | |
| 566 (or gnuserv-kill-quietly | |
| 567 (not (gnuserv-buffer-p (current-buffer))) | |
| 568 (yes-or-no-p | |
| 569 (format "Buffer %s belongs to gnuserv client(s); kill anyway? " | |
| 570 (current-buffer))))) | |
| 571 | |
| 572 (add-hook 'kill-buffer-query-functions | |
| 573 'gnuserv-kill-buffer-query-function) | |
| 574 | |
| 575 (defun gnuserv-kill-emacs-query-function () | |
| 576 (or gnuserv-kill-quietly | |
| 577 (not (some 'gnuclient-buffers gnuserv-clients)) | |
| 578 (yes-or-no-p "Gnuserv buffers still have clients; exit anyway? "))) | |
| 579 | |
| 580 (add-hook 'kill-emacs-query-functions | |
| 581 'gnuserv-kill-emacs-query-function) | |
| 582 | |
| 583 ;; If the device of a client is to be deleted, the client should die | |
| 584 ;; as well. This is why we hook into `delete-device-hook'. | |
| 585 (defun gnuserv-check-device (device) | |
| 586 (when (memq device gnuserv-devices) | |
| 587 (dolist (client gnuserv-clients) | |
| 588 (when (eq device (gnuclient-device client)) | |
| 589 ;; we must make sure that the server kill doesn't result in | |
| 590 ;; killing the device, because it would cause a device-dead | |
| 591 ;; error when `delete-device' tries to do the job later. | |
| 592 (gnuserv-kill-client client t)))) | |
| 593 (callf2 delq device gnuserv-devices)) | |
| 594 | |
| 595 (add-hook 'delete-device-hook 'gnuserv-check-device) | |
| 596 | |
| 597 (defun gnuserv-temp-file-p (buffer) | |
| 598 "Return non-nil if BUFFER contains a file considered temporary. | |
| 599 These are files whose names suggest they are repeatedly | |
| 600 reused to pass information to another program. | |
| 601 | |
| 602 The variable `gnuserv-temp-file-regexp' controls which filenames | |
| 603 are considered temporary." | |
| 604 (and (buffer-file-name buffer) | |
| 605 (string-match gnuserv-temp-file-regexp (buffer-file-name buffer)))) | |
| 606 | |
| 607 (defun gnuserv-kill-client (client &optional leave-frame) | |
| 608 "Kill the gnuclient CLIENT. | |
| 609 This will do away with all the associated buffers. If LEAVE-FRAME, | |
| 610 the function will not remove the frames associated with the client." | |
| 611 ;; Order is important: first delete client from gnuserv-clients, to | |
| 612 ;; prevent gnuserv-buffer-done-1 calling us recursively. | |
| 613 (callf2 delq client gnuserv-clients) | |
| 614 ;; Process the buffers. | |
| 615 (mapc 'gnuserv-buffer-done-1 (gnuclient-buffers client)) | |
| 616 (unless leave-frame | |
| 617 (let ((device (gnuclient-device client))) | |
| 618 ;; kill frame created by this client (if any), unless | |
| 619 ;; specifically requested otherwise. | |
| 620 ;; | |
| 621 ;; note: last frame on a device will not be deleted here. | |
| 622 (when (and (gnuclient-frame client) | |
| 623 (frame-live-p (gnuclient-frame client)) | |
| 624 (second (device-frame-list device))) | |
| 625 (delete-frame (gnuclient-frame client))) | |
| 626 ;; If the device is live, created by a client, and no longer used | |
| 627 ;; by any client, delete it. | |
| 628 (when (and (device-live-p device) | |
| 629 (memq device gnuserv-devices) | |
| 630 (second (device-list)) | |
| 631 (not (member* device gnuserv-clients | |
| 632 :key 'gnuclient-device))) | |
| 633 ;; `gnuserv-check-device' will remove it from `gnuserv-devices'. | |
| 634 (delete-device device)))) | |
| 635 ;; Notify the client. | |
| 636 (gnuserv-write-to-client (gnuclient-id client) nil)) | |
| 637 | |
| 638 ;; Do away with the buffer. | |
| 639 (defun gnuserv-buffer-done-1 (buffer) | |
| 640 (dolist (client (gnuserv-buffer-clients buffer)) | |
| 641 (callf2 delq buffer (gnuclient-buffers client)) | |
| 642 (when (null (gnuclient-buffers client)) | |
| 643 (gnuserv-kill-client client))) | |
| 644 ;; Get rid of the buffer. | |
| 645 (save-excursion | |
| 646 (set-buffer buffer) | |
| 647 (run-hooks 'gnuserv-done-hook) | |
| 648 (setq gnuserv-minor-mode nil) | |
| 649 ;; Delete the menu button. | |
| 650 (if (and (featurep 'menubar) current-menubar) | |
| 651 (delete-menu-item '("Done"))) | |
| 652 (funcall (if (gnuserv-temp-file-p buffer) | |
| 653 gnuserv-done-temp-file-function | |
| 654 gnuserv-done-function) | |
| 655 buffer))) | |
| 656 | |
| 657 | |
| 658 ;;; Higher-level functions | |
| 659 | |
| 660 ;; Choose a `next' server buffer, according to several criteria, and | |
| 661 ;; return it. If none are found, return nil. | |
| 662 (defun gnuserv-next-buffer () | |
| 663 (let* ((frame (selected-frame)) | |
| 664 (device (selected-device)) | |
| 665 client) | |
| 666 (cond | |
| 667 ;; If we have a client belonging to this frame, return | |
| 668 ;; the first buffer from it. | |
| 669 ((setq client | |
| 670 (car (member* frame gnuserv-clients :key 'gnuclient-frame))) | |
| 671 (car (gnuclient-buffers client))) | |
| 672 ;; Else, look for a device. | |
| 673 ((and | |
| 674 (memq (selected-device) gnuserv-devices) | |
| 675 (setq client | |
| 676 (car (member* device gnuserv-clients :key 'gnuclient-device)))) | |
| 677 (car (gnuclient-buffers client))) | |
| 678 ;; Else, try to find any client with at least one buffer, and | |
| 679 ;; return its first buffer. | |
| 680 ((setq client | |
| 681 (car (member-if-not #'null gnuserv-clients | |
| 682 :key 'gnuclient-buffers))) | |
| 683 (car (gnuclient-buffers client))) | |
| 684 ;; Oh, give up. | |
| 685 (t nil)))) | |
| 686 | |
| 687 (defun gnuserv-buffer-done (buffer) | |
| 688 "Mark BUFFER as \"done\" for its client(s). | |
| 689 Does the save/backup queries first, and calls `gnuserv-done-function'." | |
| 690 ;; Check whether this is the real thing. | |
| 691 (unless (gnuserv-buffer-p buffer) | |
| 692 (error "%s does not belong to a gnuserv client" buffer)) | |
| 693 ;; Backup/ask query. | |
| 694 (if (gnuserv-temp-file-p buffer) | |
| 695 ;; For a temp file, save, and do NOT make a non-numeric backup | |
| 696 ;; Why does server.el explicitly back up temporary files? | |
| 697 (let ((version-control nil) | |
| 698 (buffer-backed-up (not gnuserv-make-temp-file-backup))) | |
| 699 (save-buffer)) | |
| 700 (if (and (buffer-modified-p) | |
| 701 (y-or-n-p (concat "Save file " buffer-file-name "? "))) | |
| 702 (save-buffer buffer))) | |
| 703 (gnuserv-buffer-done-1 buffer)) | |
| 704 | |
| 705 ;; Called by `gnuserv-start-1' to clean everything. Hooked into | |
| 706 ;; `kill-emacs-hook', too. | |
| 707 (defun gnuserv-kill-all-clients () | |
| 708 "Kill all the gnuserv clients. Ruthlessly." | |
| 709 (mapc 'gnuserv-kill-client gnuserv-clients)) | |
| 710 | |
| 711 ;; This serves to run the hook and reset | |
| 712 ;; `allow-deletion-of-last-visible-frame'. | |
| 713 (defun gnuserv-prepare-shutdown () | |
| 714 (setq allow-deletion-of-last-visible-frame nil) | |
| 715 (run-hooks 'gnuserv-shutdown-hook)) | |
| 716 | |
| 717 ;; This is a user-callable function, too. | |
| 718 (defun gnuserv-shutdown () | |
| 719 "Shutdown the gnuserv server, if one is currently running. | |
| 720 All the clients will be disposed of via the normal methods." | |
| 721 (interactive) | |
| 722 (gnuserv-kill-all-clients) | |
| 723 (when gnuserv-process | |
| 724 (set-process-sentinel gnuserv-process nil) | |
| 725 (gnuserv-prepare-shutdown) | |
| 726 (condition-case () | |
| 727 (delete-process gnuserv-process) | |
| 728 (error nil)) | |
| 729 (setq gnuserv-process nil))) | |
| 730 | |
| 731 ;; Actually start the process. Kills all the clients before-hand. | |
| 732 (defun gnuserv-start-1 (&optional leave-dead) | |
| 733 ;; Shutdown the existing server, if any. | |
| 734 (gnuserv-shutdown) | |
| 735 ;; If we already had a server, clear out associated status. | |
| 736 (unless leave-dead | |
| 737 (setq gnuserv-string "" | |
| 738 gnuserv-current-client nil) | |
| 739 (let ((process-connection-type t)) | |
| 740 (setq gnuserv-process | |
| 741 (start-process "gnuserv" nil gnuserv-program))) | |
| 742 (set-process-sentinel gnuserv-process 'gnuserv-sentinel) | |
| 743 (set-process-filter gnuserv-process 'gnuserv-process-filter) | |
| 744 (process-kill-without-query gnuserv-process) | |
| 745 (setq allow-deletion-of-last-visible-frame t) | |
| 746 (run-hooks 'gnuserv-init-hook))) | |
| 747 | |
| 748 | |
| 749 ;;; User-callable functions: | |
| 750 | |
| 751 ;;;###autoload | |
| 752 (defun gnuserv-running-p () | |
| 753 "Return non-nil if a gnuserv process is running from this XEmacs session." | |
| 754 (not (not gnuserv-process))) | |
| 755 | |
| 756 ;;;###autoload | |
| 757 (defun gnuserv-start (&optional leave-dead) | |
| 758 "Allow this Emacs process to be a server for client processes. | |
| 759 This starts a gnuserv communications subprocess through which | |
| 760 client \"editors\" (gnuclient and gnudoit) can send editing commands to | |
| 761 this Emacs job. See the gnuserv(1) manual page for more details. | |
| 762 | |
| 763 Prefix arg means just kill any existing server communications subprocess." | |
| 764 (interactive "P") | |
| 765 (and gnuserv-process | |
| 766 (not leave-dead) | |
| 767 (message "Restarting gnuserv")) | |
| 768 (gnuserv-start-1 leave-dead)) | |
| 769 | |
| 770 (defun gnuserv-edit (&optional count) | |
| 771 "Mark the current gnuserv editing buffer as \"done\", and switch to next one. | |
| 772 | |
| 773 Run with a numeric prefix argument, repeat the operation that number | |
| 774 of times. If given a universal prefix argument, close all the buffers | |
| 775 of this buffer's clients. | |
| 776 | |
| 777 The `gnuserv-done-function' (bound to `kill-buffer' by default) is | |
| 778 called to dispose of the buffer after marking it as done. | |
| 779 | |
| 780 Files that match `gnuserv-temp-file-regexp' are considered temporary and | |
| 781 are saved unconditionally and backed up if `gnuserv-make-temp-file-backup' | |
| 782 is non-nil. They are disposed of using `gnuserv-done-temp-file-function' | |
| 783 \(also bound to `kill-buffer' by default). | |
| 784 | |
| 785 When all of a client's buffers are marked as \"done\", the client is notified." | |
| 786 (interactive "P") | |
| 787 (when (null count) | |
| 788 (setq count 1)) | |
| 789 (cond ((numberp count) | |
| 790 (while (natnump (decf count)) | |
| 791 (let ((frame (selected-frame))) | |
| 792 (gnuserv-buffer-done (current-buffer)) | |
| 793 (when (eq frame (selected-frame)) | |
| 794 ;; Switch to the next gnuserv buffer. However, do this | |
| 795 ;; only if we remain in the same frame. | |
| 796 (let ((next (gnuserv-next-buffer))) | |
| 797 (when next | |
| 798 (switch-to-buffer next))))))) | |
| 799 (count | |
| 800 (let* ((buf (current-buffer)) | |
| 801 (clients (gnuserv-buffer-clients buf))) | |
| 802 (unless clients | |
| 803 (error "%s does not belong to a gnuserv client" buf)) | |
| 804 (mapc 'gnuserv-kill-client (gnuserv-buffer-clients buf)))))) | |
| 805 | |
| 806 (global-set-key "\C-x#" 'gnuserv-edit) | |
| 807 | |
| 808 (provide 'gnuserv) | |
| 809 | |
| 810 ;;; gnuserv.el ends here |