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