home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / gnuserv / gnuserv.el < prev    next >
Encoding:
Text File  |  1992-03-23  |  12.4 KB  |  374 lines
  1. ; Lisp Interface code between GNU Emacs and gnuserv.
  2. ;
  3. ; This file is part of GNU Emacs.
  4. ;
  5. ; Copying is permitted under those conditions described by the GNU
  6. ; General Public License.
  7. ;
  8. ; Copyright (C) 1989 Free Software Foundation, Inc.
  9. ;
  10. ; Author: Andy Norman (ange@hplb.hpl.hp.com) based on
  11. ;         'lisp/server.el' from the 18.52 GNU Emacs distribution.
  12. ;
  13. ; Please mail bugs and suggestions to the author at the above address.
  14.  
  15.  
  16. (defconst gnuserv-rcs-header-id "$Header: gnuserv.el,v 1.12 91/03/13 15:59:27 ange Exp $")
  17.  
  18. (provide 'gnuserv)
  19.  
  20. (defvar server-program "gnuserv"
  21.   "*The program to use as the edit server")
  22.  
  23. (defvar server-process nil 
  24.   "the current server process")
  25.  
  26. (defvar server-string ""
  27.   "the last input string from the server")
  28.  
  29. (defvar current-client nil
  30.   "the client we are currently talking to")
  31.  
  32. (defvar server-clients nil
  33.   "List of current server clients.
  34. Each element is (CLIENTID BUFFER...) where CLIENTID is an integer
  35. that can be given to the server process to identify a client.
  36. When a buffer is killed, it is removed from this list.")
  37.  
  38. (defvar server-buffer-clients nil
  39.   "List of clientids for clients requesting editing of current buffer.")
  40.  
  41. (make-variable-buffer-local 'server-buffer-clients)
  42. (setq-default server-buffer-clients nil)
  43. (or (assq 'server-buffer-clients minor-mode-alist)
  44.     (setq minor-mode-alist (cons '(server-buffer-clients " Server") minor-mode-alist)))
  45.  
  46. (defun server-log (string)
  47.   "If a *server* buffer exists, write STRING to it for logging purposes."
  48.   (if (get-buffer "*server*")
  49.       (save-excursion
  50.     (set-buffer "*server*")
  51.     (goto-char (point-max))
  52.     (insert string)
  53.     (or (bolp) (newline)))))
  54.  
  55.  
  56. (defun server-sentinel (proc msg)
  57.   (cond ((eq (process-status proc) 'exit)
  58.      (server-log (message "Server subprocess exited")))
  59.     ((eq (process-status proc) 'signal)
  60.      (server-log (message "Server subprocess killed")))))
  61.  
  62.  
  63. (defun server-process-display-error (string)
  64.   "When an error has been reported from the server, display the error in a
  65. pop-up window."
  66.   (let ((cur (selected-window))
  67.     (pop-up-windows t))
  68.     (pop-to-buffer (get-buffer-create "*server*"))
  69.     (set-window-start (selected-window) (point))
  70.     (server-log string)
  71.     (select-window cur)))
  72.     
  73.  
  74. (defun server-process-filter (proc string)
  75.   "Process incoming requests from the server for GNU Emacs to do some actions."
  76.   (setq server-string (concat server-string string))
  77.   (if (string-match "\n$" server-string) ;wait till request ends with a newline
  78.       (if (string-match "^[0-9]+" server-string) ;client request id
  79.     (progn
  80.       (server-log server-string)
  81.       (let ((header (read-from-string server-string)))
  82.         (setq current-client (car header))
  83.         (condition-case oops
  84.         (eval (car (read-from-string server-string (cdr header))))
  85.           (error (setq server-string "")
  86.              (server-write-to-client current-client oops)
  87.              (setq current-client nil)
  88.              (signal (car oops) (cdr oops)))
  89.           (quit (setq server-string "")
  90.             (server-write-to-client current-client oops)
  91.             (setq current-client nil)
  92.             (signal 'quit nil)))
  93.         (setq server-string "")))
  94.     (progn                ;error string from server
  95.       (server-process-display-error server-string)
  96.       (setq server-string "")))))
  97.  
  98.  
  99. (defun server-release-outstanding-buffers ()
  100.   "Release all buffers that have clients waiting for them to be finished."
  101.   (interactive)
  102.   (while server-clients
  103.     (let ((buffer (nth 1 (car server-clients)))) ;need to do this for all buffers
  104.       (server-buffer-done buffer))))    ; destructively modifies server-clients
  105.  
  106.  
  107. (defun server-start (&optional leave-dead)
  108.   "Allow this Emacs process to be a server for client processes.
  109. This starts a server communications subprocess through which
  110. client \"editors\" can send editing commands to this Emacs job.
  111.  
  112. Prefix arg means just kill any existing server communications subprocess."
  113.   (interactive "P")
  114.   ;; kill it dead!
  115.   (if server-process
  116.       (progn
  117.     (server-release-outstanding-buffers)
  118.     (set-process-sentinel server-process nil)
  119.     (condition-case ()
  120.         (delete-process server-process)
  121.       (error nil))))
  122.   ;; If we already had a server, clear out associated status.
  123.   (if leave-dead
  124.       nil
  125.     (if server-process
  126.     (server-log (message "Restarting server")))
  127.     (setq server-string "")
  128.     (setq current-client nil)
  129.     (let ((process-connection-type t))
  130.       (setq server-process (start-process "server" nil server-program)))
  131.     (set-process-sentinel server-process 'server-sentinel)
  132.     (set-process-filter server-process 'server-process-filter)
  133.     (process-kill-without-query server-process)))
  134.  
  135.  
  136. (defun server-write-to-client (client form)
  137.   "Write the given form to the given client via the server process."
  138.   (if (and client
  139.        (eq (process-status server-process) 'run))
  140.       (let ((s (format "%s:%s\n" client form)))
  141.     (send-string server-process s)
  142.     (server-log s))))
  143.  
  144.  
  145. (defun server-eval (form)
  146.   "Evaluate form and return result to client."
  147.   (server-write-to-client current-client (eval form))
  148.   (setq current-client nil))
  149.  
  150.  
  151. (defun server-eval-quickly (form)
  152.   "Let client know that we've received the request, but eval the form
  153. afterwards in order to not keep the client waiting."
  154.   (server-write-to-client current-client nil)
  155.   (setq current-client nil)
  156.   (eval form))
  157.  
  158.  
  159. (defun server-make-window-visible ()
  160.   "Try to make this window even more visible."
  161.   (if (and (boundp 'window-system)
  162.        (boundp 'window-system-version)
  163.        (eq window-system 'x)
  164.        (eq window-system-version 11)
  165.        (fboundp 'x-remap-window))
  166.       (progn
  167.     (x-remap-window)
  168.     (accept-process-output))))    ; give window chance to re-display text
  169.  
  170.  
  171. (defun server-find-file (file)
  172.   "Edit file FILENAME.
  173. Switch to a buffer visiting file FILENAME,
  174. creating one if none already exists."
  175.   (let ((obuf (get-file-buffer file)))
  176.     (if (and obuf (set-buffer obuf))
  177.     (if (file-exists-p file)
  178.         (if (or (not (verify-visited-file-modtime obuf))
  179.             (buffer-modified-p obuf))
  180.         (revert-buffer t nil))
  181.       (if (y-or-n-p
  182.            (concat "File no longer exists: "
  183.                file
  184.                ", write buffer to file? "))
  185.           (write-file file)))
  186.       (set-buffer (find-file-noselect file))))
  187.   (switch-to-buffer (current-buffer)))
  188.  
  189.  
  190. (defun server-edit-files-quickly (l)
  191.   "For each (lineno . file) pair in the given list, edit the file and goto the
  192. given line number. Note that unlike server-edit-files, no information is saved
  193. about clients waiting for this buffer to be killed."
  194.   (server-write-to-client current-client nil)
  195.   (setq current-client nil)
  196.   (server-make-window-visible)
  197.   (while l
  198.     (let ((line (car (car l)))
  199.       (path (cdr (car l))))
  200.       (server-find-file path)
  201.       (goto-line line))
  202.     (setq l (cdr l))))
  203.  
  204.  
  205. (defun server-edit-files (l)
  206.   "For each (lineno . file) pair in the given list, edit the given file for the
  207. client and save enough information such that server-kill-buffer can let the client
  208. know when the buffer has been finished with."
  209.   (server-make-window-visible)
  210.   (while l
  211.     (let ((line (car (car l)))
  212.       (path (cdr (car l))))
  213.       (server-find-file path)
  214.       (let ((old-clients (assq current-client server-clients))
  215.         (buffer (current-buffer)))
  216.     (goto-line line)
  217.     (setq server-buffer-clients
  218.           (cons current-client server-buffer-clients))
  219.     (if old-clients            ;client already waiting for buffers?
  220.         (nconc old-clients (list buffer)) ;yes -- append this one as well
  221.       (setq server-clients        ;nope -- make a new record
  222.         (cons (list current-client buffer)
  223.               server-clients)))))
  224.       (setq l (cdr l)))
  225.   (message (substitute-command-keys
  226.         "When done with a buffer, type \\[server-edit].")))
  227.  
  228.  
  229. (defun server-get-buffer (buffer)
  230.   "One arg, a string or a buffer. Return either a buffer object or
  231. throw an error if the buffer named was not a buffer."
  232.   (if (null buffer)
  233.       (current-buffer)
  234.     (let ((buf (get-buffer buffer)))
  235.       (if (null buf)
  236.       (if (stringp buffer)
  237.           (error "No buffer named %s" buffer)
  238.         (error "Invalid buffer argument"))
  239.     buf))))
  240.  
  241.  
  242. (defun server-kill-buffer (buffer)
  243.   "One arg, a string or a buffer.  Get rid of the specified buffer.
  244. NOTE: This function has been enhanced to allow for remote editing
  245. in the following way:
  246.  
  247. If the buffer is waited upon by one or more clients, and a client is
  248. not waiting for other buffers to be killed, then the client is told
  249. that the buffer has been killed."
  250.   (interactive "bKill buffer ")
  251.   (setq buffer (server-get-buffer buffer))
  252.   (if (buffer-name buffer)
  253.       (save-excursion
  254.     (set-buffer buffer)
  255.     (let ((old-clients server-clients))
  256.       (server-real-kill-buffer buffer) ;try to kill it
  257.       (if (buffer-name buffer)    ;succeeded in killing?
  258.           nil            ;nope
  259.         (while old-clients
  260.           (let ((client (car old-clients)))
  261.         (delq buffer client)
  262.         (if (cdr client)    ;pending buffers?
  263.             nil            ;yep
  264.           (server-write-to-client (car client) nil) ;nope, tell client
  265.           (setq server-clients (delq client server-clients))))
  266.           (setq old-clients (cdr old-clients))))))))
  267.  
  268.  
  269. (defun server-kill-all-local-variables ()
  270.   "Eliminate all the buffer-local variable values of the current buffer.
  271. This buffer will then see the default values of all variables.
  272. NOTE: This function has been modified to ignore the variable 
  273. server-buffer-clients."
  274.   (let ((clients server-buffer-clients))
  275.     (server-real-kill-all-local-variables)
  276.     (if clients
  277.     (setq server-buffer-clients clients))))
  278.  
  279.  
  280. (or (fboundp 'server-real-kill-buffer)
  281.   (fset 'server-real-kill-buffer (symbol-function 'kill-buffer)))
  282.  
  283. (fset 'kill-buffer 'server-kill-buffer)
  284.  
  285. (or (fboundp 'server-real-kill-all-local-variables)
  286.     (fset 'server-real-kill-all-local-variables
  287.       (symbol-function 'kill-all-local-variables)))
  288.  
  289. (fset 'kill-all-local-variables 'server-kill-all-local-variables)
  290.  
  291.  
  292. (defun server-buffer-done (buffer)
  293.   "Mark BUFFER as \"done\" for its client(s).
  294. Buries the buffer, and returns another server buffer
  295. as a suggestion for what to select next."
  296.   (let ((next-buffer nil)
  297.     (old-clients server-clients))
  298.     (while old-clients
  299.       (let ((client (car old-clients)))
  300.     (or next-buffer 
  301.         (setq next-buffer (nth 1 (memq buffer client))))
  302.     (delq buffer client)
  303.     ;; If client now has no pending buffers,
  304.     ;; tell it that it is done, and forget it entirely.
  305.     (if (cdr client)
  306.         nil
  307.       (server-write-to-client (car client) nil)
  308.       (setq server-clients (delq client server-clients))))
  309.       (setq old-clients (cdr old-clients)))
  310.     (if (buffer-name buffer)
  311.     (save-excursion
  312.       (set-buffer buffer)
  313.       (setq server-buffer-clients nil)))
  314.     (bury-buffer buffer)
  315.     next-buffer))
  316.  
  317.  
  318. (defun mh-draft-p (buffer)
  319.   "Return non-nil if this BUFFER is an mh <draft> file.
  320. Since MH deletes draft *BEFORE* it is edited, the server treats them specially."
  321.  ;; This may not be appropriately robust for all cases.
  322.   (string= (buffer-name buffer) "draft"))
  323.  
  324.  
  325. (defun server-done ()
  326.   "Offer to save current buffer, mark it as \"done\" for clients,
  327. bury it, and return a suggested buffer to select next."
  328.   (let ((buffer (current-buffer)))
  329.     (if server-buffer-clients
  330.     (progn
  331.        (if (mh-draft-p buffer)
  332.            (progn (save-buffer)
  333.              (write-region (point-min) (point-max)
  334.                    (concat buffer-file-name "~"))
  335.              (kill-buffer buffer))
  336.         (if (and (buffer-modified-p)
  337.              (y-or-n-p (concat "Save file " buffer-file-name "? ")))
  338.         (save-buffer buffer)))
  339.       (server-buffer-done buffer)))))
  340.  
  341.  
  342. (defun server-edit (&optional arg)
  343.   "Switch to next server editing buffer; say \"Done\" for current buffer.
  344. If a server buffer is current, it is marked \"done\" and optionally saved.
  345. MH <draft> files are always saved and backed up, no questions asked.
  346. When all of a client's buffers are marked as \"done\", the client is notified.
  347.  
  348. If invoked with a prefix argument, or if there is no server process running, 
  349. starts server process and that is all.  Invoked by \\[server-edit]."
  350.   (interactive "P")
  351.   (if (or arg
  352.       (not server-process)
  353.       (memq (process-status server-process) '(signal exit)))
  354.       (server-start nil)
  355.     (server-switch-buffer (server-done))))
  356.  
  357. (defun server-switch-buffer (next-buffer)
  358.   "Switch to another buffer, preferably one that has a client.
  359. Arg NEXT-BUFFER is a suggestion; if it is a live buffer, use it."
  360.   (if next-buffer
  361.       (if (and (bufferp next-buffer)
  362.            (buffer-name next-buffer))
  363.       (switch-to-buffer next-buffer)
  364.     ;; If NEXT-BUFFER is a dead buffer,
  365.     ;; remove the server records for it
  366.     ;; and try the next surviving server buffer.
  367.     (server-switch-buffer
  368.      (server-buffer-done next-buffer)))
  369.     (if server-clients
  370.     (server-switch-buffer (nth 1 (car server-clients)))
  371.       (switch-to-buffer (other-buffer)))))
  372.  
  373. (global-set-key "\C-x#" 'server-edit)
  374.