Mercurial > hg > xemacs-beta

comparison lisp/packages/gnuserv.el @ 165:5a88923fcbfe r20-3b9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b9
author cvs
date Mon, 13 Aug 2007 09:44:42 +0200
parents 25f70ba0133c
children 85ec50267440
comparison
equal deleted inserted replaced
164:4e0740e5aab2 165:5a88923fcbfe
1 ;;; gnuserv.el --- Lisp interface code between Emacs and gnuserv 1 ;;; gnuserv.el --- Lisp interface code between Emacs and gnuserv
2 ;; Copyright (C) 1989-1997 Free Software Foundation, Inc. 2 ;; Copyright (C) 1989-1997 Free Software Foundation, Inc.
3 3
4 ;; Version: 3.3 4 ;; Version: 3.4
5 ;; Author: Andy Norman (ange@hplb.hpl.hp.com), originally based on server.el 5 ;; Author: Andy Norman (ange@hplb.hpl.hp.com), originally based on server.el
6 ;; Hrvoje Niksic <hniksic@srce.hr> 6 ;; Hrvoje Niksic <hniksic@srce.hr>
7 ;; Maintainer: Jan Vroonhof <vroonhof@math.ethz.ch>, 7 ;; Maintainer: Jan Vroonhof <vroonhof@math.ethz.ch>,
8 ;; Hrvoje Niksic <hniksic@srce.hr> 8 ;; Hrvoje Niksic <hniksic@srce.hr>
9 ;; Keywords: environment, processes, terminals 9 ;; Keywords: environment, processes, terminals
72 ;; Jan Vroonhof 72 ;; Jan Vroonhof
73 ;; Customized. 73 ;; Customized.
74 ;; 74 ;;
75 ;; Hrvoje Niksic <hniksic@srce.hr> May/1997 75 ;; Hrvoje Niksic <hniksic@srce.hr> May/1997
76 ;; Completely rewritten. Now uses `defstruct' and other CL stuff 76 ;; Completely rewritten. Now uses `defstruct' and other CL stuff
77 ;; to define clients cleanly. Dave, thanks! 77 ;; to define clients cleanly. Many thanks to Dave Gillespie!
78 78
79 79
80 ;;; Code: 80 ;;; Code:
81 81
82 (defconst gnuserv-rcs-version 82 (defconst gnuserv-rcs-version
83 "$Id: gnuserv.el,v 1.10 1997/05/29 23:50:05 steve Exp $") 83 "$Id: gnuserv.el,v 1.11 1997/06/26 02:31:17 steve Exp $")
84 84
85 (defgroup gnuserv nil 85 (defgroup gnuserv nil
86 "The gnuserv suite of programs to talk to Emacs from outside." 86 "The gnuserv suite of programs to talk to Emacs from outside."
87 :group 'environment 87 :group 'environment
88 :group 'processes 88 :group 'processes
185 185
186 186
187 ;; The old functions are provided as aliases, to avoid breaking .emacs 187 ;; The old functions are provided as aliases, to avoid breaking .emacs
188 ;; files. However, they are obsolete and should be avoided. 188 ;; files. However, they are obsolete and should be avoided.
189 189
190 (defvaralias 'server-frame 'gnuserv-frame) 190 (define-obsolete-variable-alias 'server-frame 'gnuserv-frame)
191 (defvaralias 'server-done-function 'gnuserv-done-function) 191 (define-obsolete-variable-alias 'server-done-function 'gnuserv-done-function)
192 (defvaralias 'server-done-temp-file-function 'gnuserv-done-temp-file-function) 192 (define-obsolete-variable-alias 'server-done-temp-file-function
193 (defvaralias 'server-find-file-function 'gnuserv-find-file-function) 193 'gnuserv-done-temp-file-function)
194 (defvaralias 'server-program 'gnuserv-program) 194 (define-obsolete-variable-alias 'server-find-file-function
195 (defvaralias 'server-visit-hook 'gnuserv-visit-hook) 195 'gnuserv-find-file-function)
196 (defvaralias 'server-done-hook 'gnuserv-done-hook) 196 (define-obsolete-variable-alias 'server-program
197 (defvaralias 'server-kill-quietly 'gnuserv-kill-quietly) 197 'gnuserv-program)
198 (defvaralias 'server-temp-file-regexp 'gnuserv-temp-file-regexp) 198 (define-obsolete-variable-alias 'server-visit-hook
199 (defvaralias 'server-make-temp-file-backup 'gnuserv-make-temp-file-backup) 199 'gnuserv-visit-hook)
200 (define-obsolete-variable-alias 'server-done-hook
201 'gnuserv-done-hook)
202 (define-obsolete-variable-alias 'server-kill-quietly
203 'gnuserv-kill-quietly)
204 (define-obsolete-variable-alias 'server-temp-file-regexp
205 'gnuserv-temp-file-regexp)
206 (define-obsolete-variable-alias 'server-make-temp-file-backup
207 'gnuserv-make-temp-file-backup)
200 208
201 209
202 ;;; Internal variables: 210 ;;; Internal variables:
203 211
204 (defstruct gnuclient 212 (defstruct gnuclient
473 ;; A helper function; used by others. Try avoiding it whenever 481 ;; A helper function; used by others. Try avoiding it whenever
474 ;; possible, because it is slow, and conses a list. Use 482 ;; possible, because it is slow, and conses a list. Use
475 ;; `gnuserv-buffer-p' when appropriate, for instance. 483 ;; `gnuserv-buffer-p' when appropriate, for instance.
476 (defun gnuserv-buffer-clients (buffer) 484 (defun gnuserv-buffer-clients (buffer)
477 "Returns a list of clients to which BUFFER belongs." 485 "Returns a list of clients to which BUFFER belongs."
478 (let ((client gnuserv-clients) 486 (let (res)
479 res) 487 (dolist (client gnuserv-clients)
480 (while client 488 (when (memq buffer (gnuclient-buffers client))
481 (if (memq buffer (gnuclient-buffers (car client))) 489 (push client res)))
482 (push (car client) res))
483 (pop client))
484 res)) 490 res))
485 491
486 ;; Like `gnuserv-buffer-clients', but returns a boolean; doesn't 492 ;; Like `gnuserv-buffer-clients', but returns a boolean; doesn't
487 ;; collect a list. 493 ;; collect a list.
488 (defun gnuserv-buffer-p (buffer) 494 (defun gnuserv-buffer-p (buffer)
497 ;; `kill-buffer' (thanks God). 503 ;; `kill-buffer' (thanks God).
498 (defun gnuserv-kill-buffer-function () 504 (defun gnuserv-kill-buffer-function ()
499 "Remove the buffer from the buffer lists of all the clients it belongs to. 505 "Remove the buffer from the buffer lists of all the clients it belongs to.
500 Any client that remains \"empty\" after the removal is informed that the 506 Any client that remains \"empty\" after the removal is informed that the
501 editing has ended." 507 editing has ended."
502 (let* ((buf (current-buffer)) 508 (let* ((buf (current-buffer)))
503 (clients (gnuserv-buffer-clients buf))) 509 (dolist (client (gnuserv-buffer-clients buf))
504 (while clients 510 (callf2 delq buf (gnuclient-buffers client))
505 (callf2 delq buf (gnuclient-buffers (car clients)))
506 ;; If no more buffers, kill the client. 511 ;; If no more buffers, kill the client.
507 (when (null (gnuclient-buffers (car clients))) 512 (when (null (gnuclient-buffers client))
508 (gnuserv-kill-client (car clients))) 513 (gnuserv-kill-client client)))))
509 (pop clients))))
510 514
511 (add-hook 'kill-buffer-hook 'gnuserv-kill-buffer-function) 515 (add-hook 'kill-buffer-hook 'gnuserv-kill-buffer-function)
512 516
513 ;; Ask for confirmation before killing a buffer that belongs to a 517 ;; Ask for confirmation before killing a buffer that belongs to a
514 ;; living client. 518 ;; living client.
532 536
533 ;; If the device of a client is to be deleted, the client should die 537 ;; If the device of a client is to be deleted, the client should die
534 ;; as well. This is why we hook into `delete-device-hook'. 538 ;; as well. This is why we hook into `delete-device-hook'.
535 (defun gnuserv-check-device (device) 539 (defun gnuserv-check-device (device)
536 (when (memq device gnuserv-devices) 540 (when (memq device gnuserv-devices)
537 (let ((client gnuserv-clients)) 541 (dolist (client gnuserv-clients)
538 (while client 542 (when (eq device (gnuclient-device client))
539 (when (eq device (gnuclient-device (car client))) 543 ;; we must make sure that the server kill doesn't result in
540 ;; we must make sure that the server kill doesn't result in 544 ;; killing the device, because it would cause a device-dead
541 ;; killing the device, because it would cause a device-dead 545 ;; error when `delete-device' tries to do the job later.
542 ;; error when `delete-device' tries to do the job later. 546 (gnuserv-kill-client (car client) t))))
543 (gnuserv-kill-client (car client) t)) 547 (callf2 delq device gnuserv-devices))
544 (pop client)))
545 (callf2 delq device gnuserv-devices)))
546 548
547 (add-hook 'delete-device-hook 'gnuserv-check-device) 549 (add-hook 'delete-device-hook 'gnuserv-check-device)
548 550
549 (defun gnuserv-temp-file-p (buffer) 551 (defun gnuserv-temp-file-p (buffer)
550 "Return non-nil if BUFFER contains a file considered temporary. 552 "Return non-nil if BUFFER contains a file considered temporary.
587 ;; Notify the client. 589 ;; Notify the client.
588 (gnuserv-write-to-client (gnuclient-id client) nil)) 590 (gnuserv-write-to-client (gnuclient-id client) nil))
589 591
590 ;; Do away with the buffer. 592 ;; Do away with the buffer.
591 (defun gnuserv-buffer-done-1 (buffer) 593 (defun gnuserv-buffer-done-1 (buffer)
592 (let ((clients (gnuserv-buffer-clients buffer))) 594 (dolist (client (gnuserv-buffer-clients buffer))
593 (while clients 595 (callf2 delq buffer (gnuclient-buffers client))
594 (callf2 delq buffer (gnuclient-buffers (car clients))) 596 (when (null (gnuclient-buffers client))
595 (when (null (gnuclient-buffers (car clients))) 597 (gnuserv-kill-client client)))
596 (gnuserv-kill-client (car clients))) 598 ;; Get rid of the buffer
597 (pop clients)) 599 (save-excursion
598 ;; Get rid of the buffer 600 (set-buffer buffer)
599 (save-excursion 601 (run-hooks 'gnuserv-done-hook)
600 (set-buffer buffer) 602 (setq gnuserv-minor-mode nil)
601 (run-hooks 'gnuserv-done-hook) 603 (funcall (if (gnuserv-temp-file-p buffer)
602 (setq gnuserv-minor-mode nil) 604 gnuserv-done-temp-file-function
603 (funcall (if (gnuserv-temp-file-p buffer) 605 gnuserv-done-function)
604 gnuserv-done-temp-file-function 606 buffer)))
605 gnuserv-done-function)
606 buffer))))
607 607
608 608
609 ;;; Higher-level functions 609 ;;; Higher-level functions
610 610
611 ;; Choose a `next' server buffer, according to several criteria, and 611 ;; Choose a `next' server buffer, according to several criteria, and
627 (car (member* device gnuserv-clients :key 'gnuclient-device)))) 627 (car (member* device gnuserv-clients :key 'gnuclient-device))))
628 (car (gnuclient-buffers client))) 628 (car (gnuclient-buffers client)))
629 ;; Else, try to find any client with at least one buffer, and 629 ;; Else, try to find any client with at least one buffer, and
630 ;; return its first buffer. 630 ;; return its first buffer.
631 ((setq client 631 ((setq client
632 (car (member-if-not 'null gnuserv-clients 632 (car (member-if-not #'null gnuserv-clients
633 :key 'gnuclient-buffers))) 633 :key 'gnuclient-buffers)))
634 (car (gnuclient-buffers client))) 634 (car (gnuclient-buffers client)))
635 ;; Oh, give up. 635 ;; Oh, give up.
636 (t nil)))) 636 (t nil))))
637 637