xemacs-beta: lisp/packages/gnuserv.el comparison

comparison lisp/packages/gnuserv.el @ 151:59463afc5666 r20-3b2

Import from CVS: tag r20-3b2

author	cvs
date	Mon, 13 Aug 2007 09:37:19 +0200
parents	538048ae2ab8
children	25f70ba0133c

comparison

equal deleted inserted replaced

-:8ebb1c0f0f6f
+:59463afc5666
 ;;; gnuserv.el --- Lisp interface code between Emacs and gnuserv
 ;; Copyright (C) 1989-1997 Free Software Foundation, Inc.
-;; Version: 3.1
+;; Version: 3.2
 ;; Author: Andy Norman (ange@hplb.hpl.hp.com), originally based on server.el
 ;;         Hrvoje Niksic <hniksic@srce.hr>
 ;; Keywords: environment, processes, terminals
 ;; This file is part of XEmacs.
 ;;; Code:
 (defconst gnuserv-rcs-version
-"$Id: gnuserv.el,v 1.8 1997/05/18 03:40:06 steve Exp $")
+"$Id: gnuserv.el,v 1.9 1997/05/23 01:36:30 steve Exp $")
 (defgroup gnuserv nil
 "The gnuserv suite of programs to talk to Emacs from outside."
 :group 'environment
 :group 'processes
 The hook functions are called after the file has been visited, with the
 current buffer set to the visiting buffer."
 :type 'hook
 :group 'gnuserv)
+(defcustom gnuserv-init-hook nil
+"*Hook run after the server is started."
+:type 'hook
+:group 'gnuserv)
+(defcustom gnuserv-shutdown-hook nil
+"*Hook run before the server exits."
+:type 'hook
+:group 'gnuserv)
 (defcustom gnuserv-kill-quietly nil
 "*Non-nil means to kill buffers with clients attached without requiring confirmation."
 :type 'boolean
 :group 'gnuserv)
 ;; We want the client-infested buffers to have some modeline
 ;; identification, so we'll make a "minor mode".
 (defvar gnuserv-minor-mode nil)
 (make-variable-buffer-local 'gnuserv-mode)
-(pushnew '(gnuserv-minor-mode " Server") minor-mode-alist)
+(pushnew '(gnuserv-minor-mode " Server") minor-mode-alist
+	  :test 'equal)
 ;; Sample gnuserv-frame functions
 (defun gnuserv-main-frame-function (type)
 gnuserv-special-frame)
 ;;; Communication functions
+;; We used to restart the server here, but it's too risky -- if
+;; something goes awry, it's too easy to wind up in a loop.
 (defun gnuserv-sentinel (proc msg)
 (case (process-status proc)
-(exit (message "Gnuserv subprocess exited; restarting")
+(exit
-	  ;; This will also kill all the existing clients.
+(message
-	  (gnuserv-start-1))
+(substitute-command-keys
-(closed (message "Gnuserv subprocess closed"))
+"Gnuserv subprocess exited; restart with `\\[gnuserv-start]'"))
-(signal (message "Gnuserv subprocess killed"))))
+(gnuserv-prepare-shutdown))
+(signal
+(message
+(substitute-command-keys
+"Gnuserv subprocess killed; restart with `\\[gnuserv-start]'"))
+(gnuserv-prepare-shutdown))
+(closed
+(message
+(substitute-command-keys
+"Gnuserv subprocess closed; restart with `\\[gnuserv-start]'"))
+(gnuserv-prepare-shutdown))))
+;; This function reads client requests from our current server.  Every
+;; client is identified by a unique ID within the server
+;; (incidentally, the same ID is the file descriptor the server uses
+;; to communicate to client).
+;;
+;; The request string can arrive in several chunks.  As the request
+;; ends with \C-d, we check for that character at the end of string.
+;; If not found, keep reading, and concatenating to former strings.
+;; So, if at first read we receive "5 (gn", that text will be stored
+;; to gnuserv-string.  If we then receive "us)\C-d", the two will be
+;; concatenated, `current-client' will be set to 5, and `(gnus)' form
+;; will be evaluated.
+;;
+;; Server will send the following:
+;;
+;; "ID <text>\C-d"  (no quotes)
+;;
+;;  ID    - file descriptor of the given client;
+;; <text> - the actual contents of the request.
 (defun gnuserv-process-filter (proc string)
 "Process gnuserv client requests to execute Emacs commands."
 (setq gnuserv-string (concat gnuserv-string string))
 ;; C-d means end of request.
 (when (string-match "\C-d$" gnuserv-string)
 	     (setq gnuserv-string "")))
 	  (t
 	   (error "%s: invalid response from gnuserv" gnuserv-string)
 	   (setq gnuserv-string "")))))
+;; This function is somewhat of a misnomer.  Actually, we write to the
+;; server (using `process-send-string' to gnuserv-process), which
+;; interprets what we say and forwards it to the client.  The
+;; incantation server understands is (from gnuserv.c):
+;;
+;; "FD/LEN:<text>\n"  (no quotes)
+;;    FD     - file descriptor of the given client (which we obtained from
+;;             the server earlier);
+;;    LEN    - length of the stuff we are about to send;
+;;    <text> - the actual contents of the request.
 (defun gnuserv-write-to-client (client-id form)
 "Write the given form to the given client via the gnuserv process."
 (when (eq (process-status gnuserv-process) 'run)
 (let* ((result (format "%s" form))
 	   (s      (format "%s/%d:%s\n" client-id
 			   (length result) result)))
 (process-send-string gnuserv-process s))))
 ;; The following two functions are helper functions, used by
 ;; gnuclient.
 (defun gnuserv-eval (form)
 "Evaluate form and return result to client."
 (eval form))
 ;; "Execute" a client connection, called by gnuclient.  This is the
 ;; backbone of gnuserv.el.
-(defun gnuserv-edit-files (type list &optional flags)
+(defun gnuserv-edit-files (type list &rest flags)
 "For each (line-number . file) pair in LIST, edit the file at line-number.
 The visited buffers are memorized, so that when \\[gnuserv-edit] is invoked
 in such a buffer, or when it is killed, or the client's device deleted, the
 client will be invoked that the edit is finished.
 TYPE should either be a (tty TTY TERM PID) list, or (x DISPLAY) list.
-If FLAGS is `quick', just edit the files in Emacs.
+If a flag is `quick', just edit the files in Emacs.
-If FLAGS is `view', view the files read-only."
+If a flag is `view', view the files read-only."
-(or (not flags)
+(let (quick view)
-(memq flags '(quick view))
+(mapc (lambda (flag)
-(error "Invalid flag %s" flags))
+	    (case flag
-(let* ((old-device-num (length (device-list)))
+	      (quick (setq quick t))
-	 (new-frame nil)
+	      (view  (setq view t))
-	 (dest-frame (if (functionp gnuserv-frame)
+	      (t     (error "Invalid flag %s" flag))))
-			 (funcall gnuserv-frame (car type))
+	  flags)
-		       gnuserv-frame))
+(let* ((old-device-num (length (device-list)))
-	 ;; The gnuserv-frame dependencies are ugly.
+	   (new-frame nil)
-	 (device (cond ((frame-live-p dest-frame)
+	   (dest-frame (if (functionp gnuserv-frame)
-			(frame-device dest-frame))
+			   (funcall gnuserv-frame (car type))
-		       ((null dest-frame)
+			 gnuserv-frame))
-			(case (car type)
+	   ;; The gnuserv-frame dependencies are ugly.
-			  (tty (apply 'make-tty-device (cdr type)))
+	   (device (cond ((frame-live-p dest-frame)
-			  (x   (make-x-device (cadr type)))
+			  (frame-device dest-frame))
-			  (t   (error "Invalid device type"))))
+			 ((null dest-frame)
-		       (t
+			  (case (car type)
-			(selected-device))))
+			    (tty (apply 'make-tty-device (cdr type)))
-	 (frame (cond ((frame-live-p dest-frame)
+			    (x   (make-x-device (cadr type)))
-		       dest-frame)
+			    (t   (error "Invalid device type"))))
-		      ((null dest-frame)
+			 (t
-		       (setq new-frame (make-frame nil device))
+			  (selected-device))))
-		       new-frame)
+	   (frame (cond ((frame-live-p dest-frame)
-		      (t (selected-frame))))
+			 dest-frame)
-	 (client (make-gnuclient :id gnuserv-current-client
+			((null dest-frame)
-				 :device device
+			 (setq new-frame (make-frame nil device))
-				 :frame new-frame)))
+			 new-frame)
-(setq gnuserv-current-client nil)
+			(t (selected-frame))))
-;; If the device was created by this client, push it to the list.
+	   (client (make-gnuclient :id gnuserv-current-client
-(and (/= old-device-num (length (device-list)))
+				   :device device
-	 (push device gnuserv-devices))
+				   :frame new-frame)))
-;; Visit all the listed files.
+(setq gnuserv-current-client nil)
-(while list
+;; If the device was created by this client, push it to the list.
-(let ((line (caar list)) (path (cdar list)))
+(and (/= old-device-num (length (device-list)))
-	(select-frame frame)
+	   (push device gnuserv-devices))
-	;; Visit the file.
+(and (frame-iconified-p frame)
-	(funcall (if (eq flags 'view)
+	   (deiconify-frame frame))
-		     gnuserv-view-file-function
+;; Visit all the listed files.
-		   gnuserv-find-file-function)
+(while list
-		 path)
+	(let ((line (caar list)) (path (cdar list)))
-	(goto-line line)
+	  (select-frame frame)
-	(run-hooks 'gnuserv-visit-hook)
+	  ;; Visit the file.
-	;; Don't memorize the quick and view buffers.
+	  (funcall (if view
-	(when (null flags)
+		       gnuserv-view-file-function
-	  (pushnew (current-buffer) (gnuclient-buffers client))
+		     gnuserv-find-file-function)
-	  (setq gnuserv-minor-mode t))
+		   path)
-	(pop list)))
+	  (goto-line line)
-(cond ((and flags (device-on-window-system-p device))
+	  (run-hooks 'gnuserv-visit-hook)
-	   ;; Exit if on X device, and quick or view.
+	  ;; Don't memorize the quick and view buffers.
-	   ;; NOTE: if the client is to finish now, it must absolutely
+	  (unless (or quick view)
-	   ;; /not/ be included to the list of clients.  This way the
+	    (pushnew (current-buffer) (gnuclient-buffers client))
-	   ;; client-ids should be unique.
+	    (setq gnuserv-minor-mode t))
-	   (gnuserv-write-to-client (gnuclient-id client) nil))
+	  (pop list)))
-	  (t
+(cond
-	   ;; Else, the client gets a vote.
+((and (or quick view)
-	   (push client gnuserv-clients)
+	     (device-on-window-system-p device))
-	   ;; Explain buffer exit options.  If dest-frame is nil, the
+	;; Exit if on X device, and quick or view.  NOTE: if the
-	   ;; user can exit via `delete-frame'.  OTOH, if FLAGS are
+	;; client is to finish now, it must absolutely /not/ be
-	   ;; nil and there are some buffers, the user can exit via
+	;; included to the list of clients.  This way the client-ids
-	   ;; `gnuserv-edit'.
+	;; should be unique.
-	   (if (and (null flags)
+	(gnuserv-write-to-client (gnuclient-id client) nil))
-		    (gnuclient-buffers client))
+(t
-	       (message (substitute-command-keys
+	;; Else, the client gets a vote.
-			 "Type `\\[gnuserv-edit]' to finish editing"))
+	(push client gnuserv-clients)
-	     (or dest-frame
+	;; Explain buffer exit options.  If dest-frame is nil, the
-		 (message (substitute-command-keys
+	;; user can exit via `delete-frame'.  OTOH, if FLAGS are nil
-			   "Type `\\[delete-frame]' to finish editing"))))))))
+	;; and there are some buffers, the user can exit via
+	;; `gnuserv-edit'.
+	(if (and (not (or quick view))
+		 (gnuclient-buffers client))
+	    (message (substitute-command-keys
+		      "Type `\\[gnuserv-edit]' to finish editing"))
+	  (or dest-frame
+	      (message (substitute-command-keys
+			"Type `\\[delete-frame]' to finish editing")))))))))
 ;;; Functions that hook into Emacs in various way to enable operation
 ;; Defined later.
 (add-hook 'kill-emacs-hook 'gnuserv-kill-all-clients t)
-;; A helper function; used by others.
+;; A helper function; used by others.  Try avoiding it whenever
+;; possible, because it is slow, and conses a list.  Use
+;; `gnuserv-buffer-p' when appropriate, for instance.
 (defun gnuserv-buffer-clients (buffer)
 "Returns a list of clients to which BUFFER belongs."
 (let ((client gnuserv-clients)
 	res)
 (while client
 (if (memq buffer (gnuclient-buffers (car client)))
 	  (push (car client) res))
 (pop client))
 res))
+;; Like `gnuserv-buffer-clients', but returns a boolean; doesn't
+;; collect a list.
+(defun gnuserv-buffer-p (buffer)
+(member* buffer gnuserv-clients
+	   :test 'memq
+	   :key 'gnuclient-buffers))
 ;; This function makes sure that a killed buffer is deleted off the
 ;; list for the particular client.
 ;;
 ;; This hooks into `kill-buffer-hook'.  It is *not* a replacement for
 ;; Ask for confirmation before killing a buffer that belongs to a
 ;; living client.
 (defun gnuserv-kill-buffer-query-function ()
 (or gnuserv-kill-quietly
-(not (gnuserv-buffer-clients (current-buffer)))
+(not (gnuserv-buffer-p (current-buffer)))
 (yes-or-no-p
 (format "Buffer %s belongs to gnuserv client(s); kill anyway? "
 	       (current-buffer)))))
 (add-hook 'kill-buffer-query-functions
 ;;; Higher-level functions
 ;; Choose a `next' server buffer, according to several criteria, and
-;; return it.  If none appropriate are found, return nil.
+;; return it.  If none are found, return nil.
 (defun gnuserv-next-buffer ()
 (let* ((frame (selected-frame))
 	 (device (selected-device))
 	 client)
 (cond
 ((and
 (memq (selected-device) gnuserv-devices)
 (setq client
 	     (car (member* device gnuserv-clients :key 'gnuclient-device))))
 (car (gnuclient-buffers client)))
-;; Else, try to find just any client, and return its first buffer.
+;; Else, try to find any client with at least one buffer, and
-(gnuserv-clients
+;; return its first buffer.
-(car (gnuclient-buffers (car gnuserv-clients))))
+((setq client
-;; Oh, give up.
+	    (car (member-if-not 'null gnuserv-clients
+				:key 'gnuserv-buffers)))
+(car (gnuclient-buffers client)))
+;; Oh, give up.
 (t nil))))
 (defun gnuserv-buffer-done (buffer)
 "Mark BUFFER as \"done\" for its client(s).
-Calls `gnuserv-done-function' and returns another gnuserv buffer as a
+Does the save/backup queries first, and calls `gnuserv-done-function'."
-suggestion for the new current buffer."
 ;; Check whether this is the real thing.
-(unless (gnuserv-buffer-clients buffer)
+(unless (gnuserv-buffer-p buffer)
 (error "%s does not belong to a gnuserv client" buffer))
 ;; Backup/ask query.
 (if (gnuserv-temp-file-p buffer)
 ;; For a temp file, save, and do NOT make a non-numeric backup
 ;; Why does server.el explicitly back up temporary files?
 	    (buffer-backed-up (not gnuserv-make-temp-file-backup)))
 	(save-buffer))
 (if (and (buffer-modified-p)
 	     (y-or-n-p (concat "Save file " buffer-file-name "? ")))
 	(save-buffer buffer)))
-(gnuserv-buffer-done-1 buffer)
+(gnuserv-buffer-done-1 buffer))
-(gnuserv-next-buffer))
 ;; Called by `gnuserv-start-1' to clean everything.  Hooked into
 ;; `kill-emacs-hook', too.
 (defun gnuserv-kill-all-clients ()
 "Kill all the gnuserv clients.  Ruthlessly."
 (mapc 'gnuserv-kill-client gnuserv-clients))
-;; Actually start the process.  Kills all the clients before-hand.
+;; This serves to run the hook and reset
-(defun gnuserv-start-1 (&optional leave-dead)
+;; `allow-deletion-of-last-visible-frame'.
+(defun gnuserv-prepare-shutdown ()
+(setq allow-deletion-of-last-visible-frame nil)
+(run-hooks 'gnuserv-shutdown-hook))
+;; This is a user-callable function, too.
+(defun gnuserv-shutdown ()
+"Shutdown the gnuserv server, if one is currently running.
+All the clients will be disposed of via the normal methods."
+(interactive)
 (gnuserv-kill-all-clients)
 (when gnuserv-process
 (set-process-sentinel gnuserv-process nil)
+(gnuserv-prepare-shutdown)
 (condition-case ()
 	(delete-process gnuserv-process)
-(error nil)))
+(error nil))
+(setq gnuserv-process nil)
+(message "Killed server")))
+;; Actually start the process.  Kills all the clients before-hand.
+(defun gnuserv-start-1 (&optional leave-dead)
+;; Shutdown the existing server, if any.
+(gnuserv-shutdown)
 ;; If we already had a server, clear out associated status.
 (unless leave-dead
-(setq gnuserv-string "")
+(setq gnuserv-string ""
-(setq gnuserv-current-client nil)
+	  gnuserv-current-client nil)
 (let ((process-connection-type t))
 (setq gnuserv-process
 	    (start-process "gnuserv" nil gnuserv-program)))
 (set-process-sentinel gnuserv-process 'gnuserv-sentinel)
 (set-process-filter gnuserv-process 'gnuserv-process-filter)
-(process-kill-without-query gnuserv-process)))
+(process-kill-without-query gnuserv-process)
+(setq allow-deletion-of-last-visible-frame t)
+(run-hooks 'gnuserv-init-hook)))
 ;;; User-callable functions:
+;;;###autoload
+(defun gnuserv-running-p ()
+"Return non-nil if a gnuserv process is running from this XEmacs session."
+(not (not gnuserv-process)))
 ;;;###autoload
 (defun gnuserv-start (&optional leave-dead)
 "Allow this Emacs process to be a server for client processes.
 This starts a gnuserv communications subprocess through which
 client \"editors\" (gnuclient and gnudoit) can send editing commands to
 this Emacs job.  See the gnuserv(1) manual page for more details.
 Prefix arg means just kill any existing server communications subprocess."
 (interactive "P")
-;; kill it dead!
 (and gnuserv-process
 (not leave-dead)
 (message "Restarting gnuserv"))
 (gnuserv-start-1 leave-dead))
-;;;###autoload
+(defun gnuserv-edit (&optional count)
-(defun gnuserv-edit (&optional arg)
 "Mark the current gnuserv editing buffer as \"done\", and switch to next one.
-The `gnuserv-done-function' is used to dispose of the buffer after marking it
+Run with a numeric prefix argument, repeat the operation that number
-as done; it is `kill-buffer' by default.
+of times.  If given a universal prefix argument, close all the buffers
+of this buffer's clients.
+The `gnuserv-done-function' (bound to `kill-buffer' by default) is
+called to dispose of the buffer after marking it as done.
 Files that match `gnuserv-temp-file-regexp' are considered temporary and
 are saved unconditionally and backed up if `gnuserv-make-temp-file-backup'
-is non-nil.  They are disposed of using `gnuserv-done-temp-file-function'.
+is non-nil.  They are disposed of using `gnuserv-done-temp-file-function'
+(also bound to `kill-buffer' by default).
-When all of a client's buffers are marked as \"done\", the client is notified.
+When all of a client's buffers are marked as \"done\", the client is notified."
-If invoked with a prefix argument, or if there is no gnuserv process
-running, only starts server process.  Invoked with \\[gnuserv-edit]."
 (interactive "P")
-(if (or arg (not gnuserv-process)
+(when (null count)
-	  (memq (process-status gnuserv-process) '(signal exit)))
+(setq count 1))
-(gnuserv-start)
+(cond ((numberp count)
-(switch-to-buffer (or (gnuserv-buffer-done (current-buffer))
+	 (let (next)
-			  (current-buffer)))))
+	   (while (natnump (decf count))
+	     (gnuserv-buffer-done (current-buffer))
-;;;###autoload
+	     (setq next (gnuserv-next-buffer))
+	     (when next
+	       (switch-to-buffer next)))))
+	(count
+	   (let* ((buf (current-buffer))
+		  (clients (gnuserv-buffer-clients buf)))
+	     (unless clients
+	       (error "%s does not belong to a gnuserv client" buf))
+	     (mapc 'gnuserv-kill-client (gnuserv-buffer-clients buf))))))
 (global-set-key "\C-x#" 'gnuserv-edit)
 (provide 'gnuserv)
 ;;; gnuserv.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/packages/gnuserv.el @ 151:59463afc5666 r20-3b2