home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gnusrvr2.zip / gnuserv.el < prev    next >
Lisp/Scheme  |  1995-02-16  |  18KB  |  497 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-1994  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. ; Updated for XEmacs, GNU Emacs 19 and Epoch V4 to use multiple frames
  16. ; by Bob Weiner, <weiner@mot.com>, 1/20/94.  (Still works with Emacs V18, too.)
  17. ;    Modified 'server-process-filter' to use \^D as end of request terminator
  18. ;      as gnuclient and gnudoit have been modified to send.  This permits
  19. ;      multi-line requests.
  20. ;    Modified 'server-make-window-visible' to work with multiple frames.
  21. ;    Modified 'server-find-file' to display in a separate frame when possible.
  22. ;    Modified 'server-edit' to delete newly created frame when used to
  23. ;      terminate an edit and to signal an error if called within a
  24. ;      non-server-edit buffer.
  25. ; Bob Weiner, <weiner@mot.com>, 5/9/94.
  26. ;    Added 'server-done-function' variable.  Made default value 'kill-buffer'
  27. ;    instead of 'bury-buffer' as in original gnuserv.el.
  28. ;
  29. ; Darrell Kindred <dkindred+@cmu.edu> May/1994
  30. ; Updated to allow multi-line return values:
  31. ;    - output to gnuserv is "m/n:xxx" where m is the client number,
  32. ;      n is the length of the data, and xxx is the data itself, followed 
  33. ;      by newline
  34. ;
  35. ; Arup Mukherjee <arup+@cmu.edu> May/1994
  36. ; Updated for XEmacs 19.10, and others:
  37. ;    - use find-file-other-screen if present
  38. ;    - new variable gnuserv-frame can be set to a frame or screen which is 
  39. ;      is used for all edited files. 
  40. ;    - check to see if server.el is already loaded and complain if it is, since
  41. ;      gnuserv.el can't coexist with server.el
  42. ;    - rename server-start to gnuserv-start, although server-start remains as
  43. ;      an alias. This allows gnuserv-start to be autoloaded from gnuserv.el
  44. ;    - changed server-get-buffer to take into account that in newer emacsen,
  45. ;      get buffer returns nil on deleted buffers.
  46. ;    - only try to create/delete frames or screens if window-system is non-nil 
  47. ;      (otherwise things don't work w/ emacs19 on a dumb terminal)
  48. ;
  49.  
  50.  
  51.  
  52. (defconst gnuserv-rcs-header-id "$Header: gnuserv.el,v 2.1 95/02/16 12:00:16 arup alpha $")
  53.  
  54.  
  55. ;; server.el and gnuserv.el can't coexist because of conflicting defvar's and
  56. ;; function names. 
  57.  
  58. (if (and (boundp 'server-buffer-clients)
  59.      (not (featurep 'gnuserv)))
  60.     (error "Can't run gnuserv because server.el appears to be loaded already"))
  61.  
  62. (defvar gnuserv-frame nil
  63.   "*If non-nil, the frame to be used to display all edited files.
  64. If nil, then a new frame is created for each file edited.
  65. This variable has no effect in XEmacs versions older than 19.9.")
  66.  
  67. (defvar server-done-function 'kill-buffer 
  68.   "*A function of one argument, a buffer, which removes the buffer after editing.
  69. Functions such as 'kill-buffer' and 'bury-buffer' are good values.")
  70.  
  71. (defvar server-program "gnuserv"
  72.   "*The program to use as the edit server")
  73.  
  74. (defvar server-process nil 
  75.   "The current server process")
  76.  
  77. (defvar server-string ""
  78.   "The last input string from the server")
  79.  
  80. (defvar current-client nil
  81.   "The client we are currently talking to")
  82.  
  83. (defvar server-clients nil
  84.   "List of current server clients.
  85. Each element is (CLIENTID BUFFER...) where CLIENTID is an integer
  86. that can be given to the server process to identify a client.
  87. When a buffer is killed, it is removed from this list.")
  88.  
  89. (defvar server-buffer-clients nil
  90.   "List of client ids for clients requesting editing of the current buffer.")
  91.  
  92. (make-variable-buffer-local 'server-buffer-clients)
  93. (setq-default server-buffer-clients nil)
  94. (or (assq 'server-buffer-clients minor-mode-alist)
  95.     (setq minor-mode-alist (cons '(server-buffer-clients " Server") 
  96.                  minor-mode-alist)))
  97.  
  98. (defun server-log (string)
  99.   "If a *server* buffer exists, write STRING to it for logging purposes."
  100.   (if (get-buffer "*server*")
  101.       (save-excursion
  102.     (set-buffer "*server*")
  103.     (goto-char (point-max))
  104.     (insert string)
  105.     (or (bolp) (newline)))))
  106.  
  107.  
  108. (defun server-sentinel (proc msg)
  109.   (cond ((eq (process-status proc) 'exit)
  110.      (server-log (message "Server subprocess exited")))
  111.     ((eq (process-status proc) 'signal)
  112.      (server-log (message "Server subprocess killed")))))
  113.  
  114.  
  115. (defun server-process-display-error (string)
  116.   "Whenever a gnuserv error is reported, display it in a pop-up window."
  117.   (let ((cur (selected-window))
  118.     (pop-up-windows t))
  119.     (pop-to-buffer (get-buffer-create "*server*"))
  120.     (set-window-start (selected-window) (point))
  121.     (server-log string)
  122.     (select-window cur)))
  123.  
  124.  
  125. (defun server-process-filter (proc string)
  126.   "Process client gnuserv requests to execute Emacs commands."
  127.   (setq server-string (concat server-string string))
  128.   (if (string-match "\^D$" server-string) ; requests end with ctrl-D
  129.       (if (string-match "^[0-9]+" server-string) ; client request id
  130.     (progn
  131.       (server-log server-string)
  132.       (let ((header (read-from-string server-string)))
  133.         (setq current-client (car header))
  134.         (condition-case oops
  135.         (eval (car (read-from-string server-string 
  136.                          (cdr header))))
  137.           (error (setq server-string "")
  138.              (server-write-to-client current-client oops)
  139.              (setq current-client nil)
  140.              (signal (car oops) (cdr oops)))
  141.           (quit (setq server-string "")
  142.             (server-write-to-client current-client oops)
  143.             (setq current-client nil)
  144.             (signal 'quit nil)))
  145.         (setq server-string "")))
  146.     (progn                ;error string from server
  147.       (server-process-display-error server-string)
  148.       (setq server-string "")))))
  149.  
  150.  
  151. (defun server-release-outstanding-buffers ()
  152.   "Release all buffers that have clients waiting for them to be finished."
  153.   (interactive)
  154.   (while server-clients
  155.     (let ((buffer (nth 1 (car server-clients)))) ; for all buffers...
  156.       (server-buffer-done buffer)))) ; destructively modifies server-clients
  157.  
  158. ;;;###autoload
  159. (defun gnuserv-start (&optional leave-dead)
  160.   "Allow this Emacs process to be a server for client processes.
  161. This starts a server communications subprocess through which
  162. client \"editors\" (gnuclient and gnudoit) can send editing commands to 
  163. this Emacs job. See the gnuserv(1) manual page for more details.
  164.  
  165. Prefix arg means just kill any existing server communications subprocess."
  166.   (interactive "P")
  167.   ;; kill it dead!
  168.   (if server-process
  169.       (progn
  170.     (server-release-outstanding-buffers)
  171.     (set-process-sentinel server-process nil)
  172.     (condition-case ()
  173.         (delete-process server-process)
  174.       (error nil))))
  175.   ;; If we already had a server, clear out associated status.
  176.   (if leave-dead
  177.       nil
  178.     (if server-process
  179.     (server-log (message "Restarting server")))
  180.     (setq server-string "")
  181.     (setq current-client nil)
  182.     (let ((process-connection-type t))
  183.       (setq server-process 
  184.         (start-process "server" nil server-program)))
  185.     (set-process-sentinel server-process 'server-sentinel)
  186.     (set-process-filter server-process 'server-process-filter)
  187.     (process-kill-without-query server-process)))
  188.  
  189. ;; make gnuserv-start an alias to server-start, for backward compatibility
  190. (fset 'server-start (function gnuserv-start))
  191.  
  192.  
  193. (defun server-write-to-client (client form)
  194.   "Write the given form to the given client via the server process."
  195.   (if (and client
  196.        (eq (process-status server-process) 'run))
  197.       (let* ((result (format "%s" form))
  198.          (s      (format "%s/%d:%s\n" client (length result) result)))
  199.     (process-send-string server-process s)
  200.     (server-log s))))
  201.  
  202. (defun server-eval (form)
  203.   "Evaluate form and return result to client."
  204.   (server-write-to-client current-client (eval form))
  205.   (setq current-client nil))
  206.  
  207.  
  208. (defun server-eval-quickly (form)
  209.   "Let client know that we've received the request, but eval the form
  210. afterwards in order to not keep the client waiting."
  211.   (server-write-to-client current-client nil)
  212.   (setq current-client nil)
  213.   (eval form))
  214.  
  215.  
  216. (defun server-make-window-visible ()
  217.   "Try to make this window even more visible."
  218.   (and (boundp 'window-system)
  219.        (boundp 'window-system-version)
  220.        (eq window-system 'x)
  221.        (eq window-system-version 11)
  222.        (cond ((fboundp 'raise-frame)
  223.           (raise-frame (selected-frame)))
  224.          ((fboundp 'deiconify-screen)
  225.           (deiconify-screen (selected-screen))
  226.           (raise-screen (selected-screen)))
  227.          ((fboundp 'mapraised-screen)
  228.           (mapraised-screen))
  229.          ((fboundp 'x-remap-window)
  230.           (x-remap-window)
  231.           ;; give window chance to re-display text
  232.           (accept-process-output)))))
  233.  
  234.  
  235. (defun server-find-file (file)
  236.   "Edit file FILENAME.
  237. Switch to a buffer visiting file FILENAME,
  238. creating one if none already exists."
  239.   (let ((obuf (get-file-buffer file)))
  240.     (if (and obuf (set-buffer obuf))
  241.     (if (file-exists-p file)
  242.         (if (or (not (verify-visited-file-modtime obuf))
  243.             (buffer-modified-p obuf))
  244.         (revert-buffer t nil))
  245.       (if (y-or-n-p
  246.            (concat "File no longer exists: "
  247.                file
  248.                ", write buffer to file? "))
  249.           (write-file file))))
  250.     (cond ((and window-system
  251.         gnuserv-frame (fboundp 'frame-live-p)    ;; v19 & Xemacs 19.12+
  252.         (frame-live-p gnuserv-frame))
  253.        (select-frame gnuserv-frame)
  254.        (find-file file))
  255.  
  256.       ((and window-system
  257.         gnuserv-frame (fboundp 'live-screen-p)   ;; XEmacs 19.9+
  258.         (live-screen-p gnuserv-frame))
  259.        (select-screen gnuserv-frame)          
  260.        (find-file file))
  261.       
  262.       ((and window-system
  263.         (fboundp 'select-frame))                 ;; v19 & XEmacs 19.12+
  264.        (select-frame (make-frame))
  265.        (find-file file))
  266.  
  267.       ((and window-system
  268.         (fboundp 'select-screen)                 ;; XEmacs 19.10+
  269.         (fboundp 'make-screen))
  270.        (select-screen (make-screen))
  271.        (find-file file))
  272.       
  273.       ((and (eq window-system 'x)                    ;; XEmacs 19.9-
  274.         (fboundp 'select-screen)
  275.         (fboundp 'x-create-screen))
  276.        (select-screen (x-create-screen nil))
  277.        (find-file file))
  278.  
  279.       ((and window-system
  280.         (fboundp 'create-screen))                ;; epoch
  281.        (if (screenp gnuserv-frame)
  282.            (progn (select-screen gnuserv-frame)
  283.               (find-file file))
  284.          (select-screen (create-screen (find-file-noselect file)))))
  285.  
  286.       (t (find-file file)))))                        ;; emacs18+
  287.  
  288.  
  289. (defun server-edit-files-quickly (list)
  290.   "For each (line-number . file) pair in LIST, edit the file at line-number.
  291. Unlike (server-edit-files), no information is saved about clients waiting on
  292. edits to this buffer."
  293.   (server-write-to-client current-client nil)
  294.   (setq current-client nil)
  295.   (while list
  296.     (let ((line (car (car list)))
  297.       (path (cdr (car list))))
  298.       (server-find-file path)
  299.       (server-make-window-visible)
  300.       (goto-line line))
  301.     (setq list (cdr list))))
  302.  
  303.  
  304. (defun server-edit-files (list)
  305.   "For each (line-number . file) pair in LIST, edit the file at line-number.
  306. Save enough information for (server-kill-buffer) to inform the client when
  307. the edit is finished."
  308.   (while list
  309.     (let ((line (car (car list)))
  310.       (path (cdr (car list))))
  311.       (server-find-file path)
  312.       (server-make-window-visible)
  313.       (let ((old-clients (assq current-client server-clients))
  314.         (buffer (current-buffer)))
  315.     (goto-line line)
  316.     (setq server-buffer-clients
  317.           (cons current-client server-buffer-clients))
  318.     (if old-clients            ;client already waiting for buffers?
  319.         (nconc old-clients (list buffer)) ;yes -- append this one as well
  320.       (setq server-clients        ;nope -- make a new record
  321.         (cons (list current-client buffer)
  322.               server-clients)))))
  323.       (setq list (cdr list)))
  324.   (message (substitute-command-keys
  325.         (if (and (boundp 'infodock-version) window-system)
  326.         "Type {\\[server-edit]} or select Frame/Delete to finish edit."
  327.           "When done with a buffer, type \\[server-edit]."))))
  328.  
  329.  
  330. (defun server-get-buffer (buffer)
  331.   "One arg, a BUFFER or a buffer name.  Return the buffer object even if killed.
  332. Signal an error if there is no record of BUFFER."
  333.   (if (null buffer)
  334.       (current-buffer)
  335.     (let ((buf (get-buffer buffer)))
  336.       (if (null buf)
  337.       (if (bufferp buffer)
  338.           buffer
  339.         (if (stringp buffer)
  340.         (error "No buffer named %s" buffer)
  341.           (error "Invalid buffer argument")))
  342.     buf))))
  343.  
  344. (defun server-kill-buffer (buffer)
  345.   "Kill the BUFFER.  The argument may be a buffer object or buffer name. 
  346. NOTE: This function has been enhanced to allow for remote editing
  347. in the following way:
  348.  
  349. If the buffer is waited upon by one or more clients, and a client is
  350. not waiting for other buffers to be killed, then the client is told
  351. that the buffer has been killed."
  352.   (interactive "bKill buffer ")
  353.   (setq buffer (server-get-buffer buffer))
  354.   (if (buffer-name buffer)
  355.       (save-excursion
  356.     (set-buffer buffer)
  357.     (let ((old-clients server-clients))
  358.       (server-real-kill-buffer buffer) ;try to kill it
  359.       (if (buffer-name buffer)    ;succeeded in killing?
  360.           nil            ;nope
  361.         (while old-clients
  362.           (let ((client (car old-clients)))
  363.         (delq buffer client)
  364.         (if (cdr client)    ;pending buffers?
  365.             nil            ;yep
  366.           (server-write-to-client (car client) nil) ;nope, tell client
  367.           (setq server-clients (delq client server-clients))))
  368.           (setq old-clients (cdr old-clients))))))))
  369.  
  370.  
  371. (defun server-kill-all-local-variables ()
  372.   "Eliminate all the buffer-local variable values of the current buffer.
  373. This buffer will then see the default values of all variables.
  374. NOTE: This function has been modified to ignore the variable 
  375. server-buffer-clients."
  376.   (let ((clients server-buffer-clients))
  377.     (server-real-kill-all-local-variables)
  378.     (if clients
  379.     (setq server-buffer-clients clients))))
  380.  
  381.  
  382. (or (fboundp 'server-real-kill-buffer)
  383.   (fset 'server-real-kill-buffer (symbol-function 'kill-buffer)))
  384.  
  385. (fset 'kill-buffer 'server-kill-buffer)
  386.  
  387. (or (fboundp 'server-real-kill-all-local-variables)
  388.     (fset 'server-real-kill-all-local-variables
  389.       (symbol-function 'kill-all-local-variables)))
  390.  
  391. (fset 'kill-all-local-variables 'server-kill-all-local-variables)
  392.  
  393.  
  394. (defun server-buffer-done (buffer)
  395.   "Mark BUFFER as \"done\" for its client(s).
  396. Buries the buffer, and returns another server buffer as a suggestion for the
  397. new current buffer."
  398.   (let ((next-buffer nil)
  399.     (old-clients server-clients))
  400.     (while old-clients
  401.       (let ((client (car old-clients)))
  402.     (or next-buffer 
  403.         (setq next-buffer (nth 1 (memq buffer client))))
  404.     (delq buffer client)
  405.     ;; If client now has no pending buffers,
  406.     ;; tell it that it is done, and forget it entirely.
  407.     (if (cdr client)
  408.         nil
  409.       (server-write-to-client (car client) nil)
  410.       (setq server-clients (delq client server-clients))))
  411.       (setq old-clients (cdr old-clients)))
  412.     (if (buffer-name buffer)
  413.     (save-excursion
  414.       (set-buffer buffer)
  415.       (setq server-buffer-clients nil)))
  416.    (funcall server-done-function buffer)
  417.     next-buffer))
  418.  
  419.  
  420. (defun mh-draft-p (buffer)
  421.   "Return non-nil if this BUFFER is an mh <draft> file. Since MH deletes 
  422. draft *BEFORE* it is edited, the server treats them specially."
  423.  ;; This may not be appropriately robust for all cases.
  424.   (string= (buffer-name buffer) "draft"))
  425.  
  426.  
  427. (defun server-done ()
  428.   "Offer to save current buffer and mark it as \"done\" for clients.
  429. Also bury it, and return a suggested new current buffer."
  430.   (let ((buffer (current-buffer)))
  431.     (if server-buffer-clients
  432.     (progn
  433.        (if (mh-draft-p buffer)
  434.            (progn (save-buffer)
  435.              (write-region (point-min) (point-max)
  436.                    (concat buffer-file-name "~"))
  437.              (kill-buffer buffer))
  438.         (if (and (buffer-modified-p)
  439.              (y-or-n-p (concat "Save file " buffer-file-name "? ")))
  440.         (save-buffer buffer)))
  441.       (server-buffer-done buffer)))))
  442.  
  443.  
  444. (defun server-edit (&optional arg)
  445.   "Switch to next server editing buffer and mark current one as \"done\".
  446. If a server buffer is current, it is marked \"done\" and optionally saved.
  447. MH <draft> files are always saved and backed up, no questions asked.
  448. When all of a client's buffers are marked as \"done\", the client is notified.
  449.  
  450. If invoked with a prefix argument, or if there is no server process running, 
  451. starts server process and that is all.  Invoked by \\[server-edit]."
  452.   (interactive "P")
  453.   (if (or arg
  454.       (not server-process)
  455.       (memq (process-status server-process) '(signal exit)))
  456.       (server-start nil)
  457.     (if server-buffer-clients
  458.     (progn (server-switch-buffer (server-done))
  459.            (cond ((or (not window-system)
  460.               (and gnuserv-frame 
  461.                    (or (and (fboundp 'frame-live-p)
  462.                     (frame-live-p gnuserv-frame))
  463.                    (and (fboundp 'live-screen-p)
  464.                     (live-screen-p gnuserv-frame))
  465.                    (and (fboundp 'create-screen)
  466.                     (screenp gnuserv-frame)))))
  467.               ())                                   ;; do nothing
  468.              ((fboundp 'delete-frame)
  469.               (delete-frame (selected-frame) t))
  470.              ((fboundp 'delete-screen)
  471.               (delete-screen))))
  472.       (error 
  473.        "(server-edit): Use only on buffers created by external programs.")
  474.       )))
  475.  
  476. (defun server-switch-buffer (next-buffer)
  477.   "Switch to NEXT-BUFFER if a live buffer, otherwise switch to another buffer
  478. with gnuserv clients. If no such buffer is available, simply choose another 
  479. one."
  480.   (if next-buffer
  481.       (if (and (bufferp next-buffer)
  482.            (buffer-name next-buffer))
  483.       (switch-to-buffer next-buffer)
  484.     ;; If NEXT-BUFFER is a dead buffer,
  485.     ;; remove the server records for it
  486.     ;; and try the next surviving server buffer.
  487.     (server-switch-buffer
  488.      (server-buffer-done next-buffer)))
  489.     (if server-clients
  490.     (server-switch-buffer (nth 1 (car server-clients)))
  491.       (switch-to-buffer (other-buffer)))))
  492.  
  493. (global-set-key "\C-x#" 'server-edit)
  494.  
  495. (provide 'gnuserv)
  496.  
  497.