; Lisp Interface code between GNU Emacs and gnuserv.
;
; This file is part of GNU Emacs.
;
; Copying is permitted under those conditions described by the GNU
; General Public License.
;
; Copyright (C) 1989-1996  Free Software Foundation, Inc.
;
; Author: Andy Norman (ange@hplb.hpl.hp.com) based on
;         'lisp/server.el' from the 18.52 GNU Emacs distribution.
;
; Please mail bugs and suggestions to the author at the above address.
;
;;; Synched up with: Not in FSF.

; Updated for XEmacs, GNU Emacs 19 and Epoch V4 to use multiple frames
; by Bob Weiner, <weiner@mot.com>, 1/20/94.  (Still works with Emacs V18, too.)
;    Modified 'server-process-filter' to use \^D as end of request terminator
;      as gnuclient and gnudoit have been modified to send.  This permits
;      multi-line requests.
;    Modified 'server-make-window-visible' to work with multiple frames.
;    Modified 'server-find-file' to display in a separate frame when possible.
;    Modified 'server-edit' to delete newly created frame when used to
;      terminate an edit and to signal an error if called within a
;      non-server-edit buffer.
; Bob Weiner, <weiner@mot.com>, 5/9/94.
;    Added 'server-done-function' variable.  Made default value 'kill-buffer'
;    instead of 'bury-buffer' as in original gnuserv.el.
;
; Darrell Kindred <dkindred+@cmu.edu> May/1994
; Updated to allow multi-line return values:
;    - output to gnuserv is "m/n:xxx" where m is the client number,
;      n is the length of the data, and xxx is the data itself, followed 
;      by newline
;
; Arup Mukherjee <arup+@cmu.edu> May/1994
; Updated for XEmacs 19.10, and others:
;    - use find-file-other-screen if present
;    - new variable gnuserv-frame can be set to a frame or screen which
;      is used for all edited files. 
;    - check to see if server.el is already loaded and complain if it is, since
;      gnuserv.el can't coexist with server.el
;    - rename server-start to gnuserv-start, although server-start remains as
;      an alias. This allows gnuserv-start to be autoloaded from gnuserv.el
;    - changed server-get-buffer to take into account that in newer emacsen,
;      get buffer returns nil on deleted buffers.
;    - only try to create/delete frames or screens if window-system is non-nil 
;      (otherwise things don't work w/ emacs19 on a dumb terminal)
;
; Ben Wing <wing@666.com> sometime in 1995
; Updated to allow `gnuattach'-type connections to the existing TTY
;
; Ben Wing <wing@666.com> May/1996
; patch to get TTY terminal type correct.
;
; Jan Vroonhof <vroonhof@math.ethz.ch> July/1996
; ported the server-temp-file-regexp feature from server.el
; ported server hooks from server.el
; ported kill-*-query functions from server.el (and made it optional)
; synced other behaviour with server.el



(defconst gnuserv-rcs-header-id "!Header: gnuserv.el,v 2.1 95/02/16 12:00:16 arup alpha !")


;; server.el and gnuserv.el can't coexist because of conflicting defvar's and
;; function names. 

(if (and (boundp 'server-buffer-clients)
	 (not (featurep 'gnuserv)))
    (error "Can't run gnuserv because server.el appears to be loaded already"))

;;;###autoload
(defvar gnuserv-frame nil
  "*If non-nil, the frame to be used to display all edited files.
If nil, then a new frame is created for each file edited.
This variable has no effect in XEmacs versions older than 19.9.")

(defvar server-done-function 'kill-buffer 
  "*A function of one argument, a buffer, which removes the buffer after editing.
Functions such as 'kill-buffer' and 'bury-buffer' are good values. See also
`server-done-temp-file-function'")

(defvar server-done-temp-file-function 'kill-buffer
  "*A function of one argument, a buffer, which removes the buffer after editing a
temporary file. Functions such as 'kill-buffer' and 'bury-buffer' are
good values. See also `server-done-function'")

(defvar server-program "gnuserv"
  "*The program to use as the edit server")


 (defvar server-visit-hook nil
   "*List of hooks to call when visiting a file for the Emacs server.")

;; defined by server.el but obsolete?
;; (defvar server-switch-hook nil
;;  "*List of hooks to call when switching to a buffer for the Emacs server.")

(defvar server-done-hook nil
  "*List of hooks to call when done editing a buffer for the Emacs server.")


(defvar server-process nil 
  "The current server process")

(defvar server-string ""
  "The last input string from the server")

(defvar server-kill-last-frame nil
  "set to t to kill last frame")

(defvar current-client nil
  "The client we are currently talking to")

(defvar server-clients nil
  "List of current server clients.
Each element is (CLIENTID BUFFER...) where CLIENTID is an integer
that can be given to the server process to identify a client.
When a buffer is killed, it is removed from this list.")

(defvar server-kill-quietly nil
  "If this variable is set then don't confirm kills of buffers with
  clients attached")


(defvar server-buffer-clients nil
  "List of client ids for clients requesting editing of the current buffer.")

(defvar server-temp-file-regexp "^/tmp/Re\\|/draft$"
  "*Regexp which should match filenames of temporary files
which are deleted and reused after each edit
by the programs that invoke the emacs server.")

(defvar server-make-temp-file-backup nil
  "Non-nil makes the server backup temporary files also")

(make-variable-buffer-local 'server-buffer-clients)
(setq-default server-buffer-clients nil)
(or (assq 'server-buffer-clients minor-mode-alist)
    (setq minor-mode-alist (cons '(server-buffer-clients " Server") 
				 minor-mode-alist)))

(defun server-temp-file-p (buffer)
  "Return non-nil if BUFFER contains a file considered temporary.
These are files whose names suggest they are repeatedly
reused to pass information to another program.

The variable `server-temp-file-regexp' controls which filenames
are considered temporary."
  (and (buffer-file-name buffer)
       (string-match server-temp-file-regexp (buffer-file-name buffer))))


(defun server-log (string)
  "If a *server* buffer exists, write STRING to it for logging purposes."
  (if (get-buffer "*server*")
      (save-excursion
	(set-buffer "*server*")
	(goto-char (point-max))
	(insert string)
	(or (bolp) (newline)))))


(defun server-sentinel (proc msg)
  (cond ((eq (process-status proc) 'exit)
	 (server-log (message "Server subprocess exited")))
	((eq (process-status proc) 'signal)
	 (server-log (message "Server subprocess killed")))))


(defun server-process-display-error (string)
  "Whenever a gnuserv error is reported, display it in a pop-up window."
  (let ((cur (selected-window))
	(pop-up-windows t))
    (pop-to-buffer (get-buffer-create "*server*"))
    (set-window-start (selected-window) (point))
    (server-log string)
    (select-window cur)))


(defun server-process-filter (proc string)
  "Process client gnuserv requests to execute Emacs commands."
  (setq server-string (concat server-string string))
  (if (string-match "\^D$" server-string) ; requests end with ctrl-D
      (if (string-match "^[0-9]+" server-string) ; client request id
	(progn
	  (server-log server-string)
	  (let ((header (read-from-string server-string)))
	    (setq current-client (car header))
	    (condition-case oops
		(eval (car (read-from-string server-string 
					     (cdr header))))
	      (error (setq server-string "")
		     (server-write-to-client current-client oops)
		     (setq current-client nil)
		     (signal (car oops) (cdr oops)))
	      (quit (setq server-string "")
		    (server-write-to-client current-client oops)
		    (setq current-client nil)
		    (signal 'quit nil)))
	    (setq server-string "")))
	(progn				;error string from server
	  (server-process-display-error server-string)
	  (setq server-string "")))))


(defun server-release-outstanding-buffers ()
  "Release all buffers that have clients waiting for them to be finished."
  (interactive)
  (while server-clients
    (let ((buffer (nth 1 (car server-clients)))) ; for all buffers...
      (server-buffer-done buffer)))) ; destructively modifies server-clients

;;;###autoload
(defun gnuserv-start (&optional leave-dead)
  "Allow this Emacs process to be a server for client processes.
This starts a server 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!
  (if server-process
      (progn
	(server-release-outstanding-buffers)
	(set-process-sentinel server-process nil)
	(condition-case ()
	    (delete-process server-process)
	  (error nil))))
  ;; If we already had a server, clear out associated status.
  (if leave-dead
      nil
    (if server-process
	(server-log (message "Restarting server")))
    (setq server-string "")
    (setq current-client nil)
    (let ((process-connection-type t))
      (setq server-process 
	    (start-process "server" nil server-program)))
    (set-process-sentinel server-process 'server-sentinel)
    (set-process-filter server-process 'server-process-filter)
    (process-kill-without-query server-process)))

;; make gnuserv-start an alias to server-start, for backward compatibility
(fset 'server-start (function gnuserv-start))

; Can gnuserv handle commands in close succesion? (See server.el line 283) JV
(defun server-write-to-client (client form)
  "Write the given form to the given client via the server process."
  (if (and client
	   (eq (process-status server-process) 'run))
      (let* ((result (format "%s" form))
	     (s      (format "%s/%d:%s\n" client (length result) result)))
	(process-send-string server-process s)
	(server-log s))))

(defun server-eval (form)
  "Evaluate form and return result to client."
  (server-write-to-client current-client (eval form))
  (setq current-client nil))


(defun server-eval-quickly (form)
  "Let client know that we've received the request, but eval the form
afterwards in order to not keep the client waiting."
  (server-write-to-client current-client nil)
  (setq current-client nil)
  (eval form))


(defun server-make-window-visible ()
  "Try to make this window even more visible."
  (and (or (and (boundp 'window-system)
		(boundp 'window-system-version)
		(eq window-system 'x)
		(eq window-system-version 11))
	   (and (fboundp 'console-type)
		(eq 'x (console-type))))
       (cond ((fboundp 'raise-frame)
	      (raise-frame (selected-frame)))
	     ((fboundp 'deiconify-screen)
	      (deiconify-screen (selected-screen))
	      (raise-screen (selected-screen)))
	     ((fboundp 'mapraised-screen)
	      (mapraised-screen))
	     ((fboundp 'x-remap-window)
	      (x-remap-window)
	      ;; give window chance to re-display text
	      (accept-process-output)))))

(defun server-tty-find-file (tty termtype pid file)
  (let ((device (make-tty-device tty termtype pid )))
    (select-frame (make-frame nil device))
    (if (not file)
	(switch-to-buffer (get-buffer-create "*scratch*"))
      (find-file file)))
  (run-hooks 'server-visit-hook))

(defun server-find-file (file)
  "Edit file FILENAME.
Switch to a buffer visiting file FILENAME,
creating one if none already exists."
  (let ((obuf (get-file-buffer file))
	;; XEmacs addition.
	(force-dialog-box-use t))
    (if (and obuf (set-buffer obuf))
	(if (file-exists-p file)
	    (if (or (not (verify-visited-file-modtime obuf))
		    (buffer-modified-p obuf))
		(revert-buffer t nil))
	  (if (y-or-n-p
	       (concat "File no longer exists: "
		       file
		       ", write buffer to file? "))
	      (write-file file))))
    (cond ((and window-system
		gnuserv-frame (fboundp 'frame-live-p)    ;; v19 & XEmacs 19.12+
		(frame-live-p gnuserv-frame))
	   (select-frame gnuserv-frame)
	   (find-file file))

	  ((and window-system
		gnuserv-frame (fboundp 'live-screen-p)   ;; XEmacs 19.9+
		(live-screen-p gnuserv-frame))
	   (select-screen gnuserv-frame)          
	   (find-file file))
	  
	  ((and window-system
		(fboundp 'select-frame))                 ;; v19 & XEmacs 19.12+
	   (select-frame (make-frame))
	   (find-file file))

	  ((and window-system
		(fboundp 'select-screen)                 ;; XEmacs 19.10+
		(fboundp 'make-screen))
	   (select-screen (make-screen))
	   (find-file file))
	  
	  ((and (eq window-system 'x)                    ;; XEmacs 19.9-
		(fboundp 'select-screen)
		(fboundp 'x-create-screen))
	   (select-screen (x-create-screen nil))
	   (find-file file))

	  ((and window-system
		(fboundp 'create-screen))                ;; epoch
	   (if (screenp gnuserv-frame)
	       (progn (select-screen gnuserv-frame)
		      (find-file file))
	     (select-screen (create-screen (find-file-noselect file)))))

	  (t (find-file file))))                          ;; emacs18+
     (run-hooks 'server-visit-hook))                        


(defun server-edit-files-quickly (list)
  "For each (line-number . file) pair in LIST, edit the file at line-number.
Unlike (server-edit-files), no information is saved about clients waiting on
edits to this buffer."
  (server-write-to-client current-client nil)
  (setq current-client nil)
  (while list
    (let ((line (car (car list)))
	  (path (cdr (car list))))
      (server-find-file path)
      (server-make-window-visible)
      (goto-line line))
    (setq list (cdr list))))


(defun server-edit-files (list)
  "For each (line-number . file) pair in LIST, edit the file at line-number.
Save enough information for (server-kill-buffer) to inform the client when
the edit is finished."
  (while list
    (let ((line (car (car list)))
	  (path (cdr (car list))))
      (server-find-file path)
      (server-make-window-visible)
      (let ((old-clients (assq current-client server-clients))
	    (buffer (current-buffer)))
	(goto-line line)
	(setq server-buffer-clients
	      (cons current-client server-buffer-clients))
	(if old-clients			;client already waiting for buffers?
	    (nconc old-clients (list buffer)) ;yes -- append this one as well
	  (setq server-clients		;nope -- make a new record
		(cons (list current-client buffer)
		      server-clients)))))
      (setq list (cdr list)))
  (message (substitute-command-keys
	    (if (and (boundp 'infodock-version) window-system)
		"Type {\\[server-edit]} or select Frame/Delete to finish edit."
	      "When done with a buffer, type \\[server-edit]."))))

(defun server-tty-edit-files (tty termtype pid list)
  "For each (line-number . file) pair in LIST, edit the file at line-number.
Save enough information for (server-kill-buffer) to inform the client when
the edit is finished."
  (or list (setq list '((1 . nil))))
  (while list
    (let ((line (car (car list)))
	  (path (cdr (car list))))
      (server-tty-find-file tty termtype pid path)
      (server-make-window-visible)
      (let ((old-clients (assq current-client server-clients))
	    (buffer (current-buffer)))
	(goto-line line)
	(setq server-buffer-clients
	      (cons current-client server-buffer-clients))
	(if old-clients			;client already waiting for buffers?
	    (nconc old-clients (list buffer)) ;yes -- append this one as well
	  (setq server-clients		;nope -- make a new record
		(cons (list current-client buffer)
		      server-clients)))))
      (setq list (cdr list)))
  (message (substitute-command-keys
	    (if (and (boundp 'infodock-version) window-system)
		"Type {\\[server-edit]} or select Frame/Delete to finish edit."
	      "When done with a buffer, type \\[server-edit]."))))

(defun server-get-buffer (buffer)
  "One arg, a BUFFER or a buffer name.  Return the buffer object even if killed.
Signal an error if there is no record of BUFFER."
  (if (null buffer)
      (current-buffer)
    (let ((buf (get-buffer buffer)))
      (if (null buf)
	  (if (bufferp buffer)
	      buffer
	    (if (stringp buffer)
		(error "No buffer named %s" buffer)
	      (error "Invalid buffer argument")))
	buf))))

(defun server-kill-buffer (buffer)
  "Kill the BUFFER.  The argument may be a buffer object or buffer name. 
NOTE: This function has been enhanced to allow for remote editing
in the following way:

If the buffer is waited upon by one or more clients, and a client is
not waiting for other buffers to be killed, then the client is told
that the buffer has been killed."
  (interactive "bKill buffer ")
  (setq buffer (server-get-buffer buffer))
  (if (buffer-name buffer)
      (save-excursion
	(set-buffer buffer)
	(let ((old-clients server-clients))
	  (server-real-kill-buffer buffer) ;try to kill it
	  (if (buffer-name buffer)	;succeeded in killing?
	      nil			;nope
	    (while old-clients
	      (let ((client (car old-clients)))
		(delq buffer client)
		(if (cdr client)	;pending buffers?
		    nil			;yep
		  (server-write-to-client (car client) nil) ;nope, tell client
		  (setq server-clients (delq client server-clients))))
	      (setq old-clients (cdr old-clients)))
	    t)))))


;; Ask before killing a server buffer.
;; It was suggested to release its client instead,
;; but I think that is dangerous--the client would proceed
;; using whatever is on disk in that file. -- rms.
(defun server-kill-buffer-query-function ()
  (or server-kill-quietly
      (not server-buffer-clients)
      (yes-or-no-p (format "Buffer `%s' still has clients; kill it? "
			   (buffer-name (current-buffer))))))

(add-hook 'kill-buffer-query-functions
 	  'server-kill-buffer-query-function)

(defun server-kill-emacs-query-function ()
  (let (live-client
	(tail server-clients))
    ;; See if any clients have any buffers that are still alive.
    (while tail
      (if (memq t (mapcar 'stringp (mapcar 'buffer-name (cdr (car tail)))))
	  (setq live-client t))
      (setq tail (cdr tail)))
    (or server-kill-quietly
        (not live-client)
	(yes-or-no-p "Server buffers still have clients; exit anyway? "))))

(add-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function)


(defun server-kill-all-local-variables ()
  "Eliminate all the buffer-local variable values of the current buffer.
This buffer will then see the default values of all variables.
NOTE: This function has been modified to ignore the variable 
server-buffer-clients."
  (let ((clients server-buffer-clients))
    (server-real-kill-all-local-variables)
    (if clients
	(setq server-buffer-clients clients))))


(or (fboundp 'server-real-kill-buffer)
  (fset 'server-real-kill-buffer (symbol-function 'kill-buffer)))

(fset 'kill-buffer 'server-kill-buffer)

(or (fboundp 'server-real-kill-all-local-variables)
    (fset 'server-real-kill-all-local-variables
	  (symbol-function 'kill-all-local-variables)))

(fset 'kill-all-local-variables 'server-kill-all-local-variables)


(defun server-buffer-done (buffer)
  "Mark BUFFER as \"done\" for its client(s).
Buries the buffer, and returns another server buffer as a suggestion for the
new current buffer."
  ; Note we do NOT return a list with a killed flag, doesn't seem usefull to me. JV
  (let ((next-buffer nil)
	(old-clients server-clients))
    (while old-clients
      (let ((client (car old-clients)))
	(or next-buffer 
	    (setq next-buffer (nth 1 (memq buffer client))))
	(delq buffer client)
	;; Delete all dead buffers from CLIENT.  (Why? JV , copyed from server.el)
	(let ((tail client))
	  (while tail
	    (and (bufferp (car tail))
		 (null (buffer-name (car tail)))
		 (delq (car tail) client))
	    (setq tail (cdr tail))))
	;; If client now has no pending buffers,
	;; tell it that it is done, and forget it entirely.
	(if (cdr client)
	    nil
	  (if (buffer-name buffer)
	      (save-excursion
		(set-buffer buffer)
		(setq server-buffer-clients nil)
		(run-hooks 'server-done-hook)))
	  ; Order is important here --
	  ; server-kill-buffer tries to notify clients that
	  ; they are done, too, but if we try and notify twice,
	  ; we are h0zed -- Hunter Kelly 3/3/97
	  (setq server-clients (delq client server-clients))
	  (if (server-temp-file-p buffer)
 	      (funcall server-done-temp-file-function buffer)
 	    (funcall server-done-function buffer))
	  (server-write-to-client (car client) nil)))
      (setq old-clients (cdr old-clients)))
    next-buffer))


(defun mh-draft-p (buffer)
  "Return non-nil if this BUFFER is an mh <draft> file. Since MH deletes 
draft *BEFORE* it is edited, the server treats them specially."
 ;; This may not be appropriately robust for all cases.
  (string= (buffer-name buffer) "draft"))


(defun server-done ()
  "Offer to save current buffer and mark it as \"done\" for clients.
Also bury it, and return a suggested new current buffer."
  (let ((buffer (current-buffer)))
    (if server-buffer-clients
	(progn
 	  (if (mh-draft-p buffer);; Does this comflict with temp-file ? JV
 	      (progn (save-buffer)
		     (write-region (point-min) (point-max)
				   (concat buffer-file-name "~"))
		     (kill-buffer buffer))
	    (if (server-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?
		(let ((version-control nil)
		      (buffer-backed-up (not server-make-temp-file-backup)))
		  (save-buffer))
	      (if (and (buffer-modified-p)
		       (y-or-n-p (concat "Save file " buffer-file-name "? ")))
		  (save-buffer buffer))))
	  (server-buffer-done buffer)))))


(defun server-edit (&optional arg)
  "Switch to next server editing
buffer and mark current one as \"done\". If a server buffer is
current, it is marked \"done\" and optionally saved. MH <draft> files
are always saved and backed up, no questions asked. Files that match
server-temp-file-regexp are considered temporary and are saved
unconditionally and
backed up if server-make-temp-file-backup is non-nil. 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 server process running, 
starts server process and that is all.  Invoked by \\[server-edit].

If `server-kill-last-frame' is t, then the final frame will be killed."
  (interactive "P")
  (if (or arg
	  (not server-process)
	  (memq (process-status server-process) '(signal exit)))
      (server-start nil)
    (if server-buffer-clients
	(progn (server-done-and-switch)
	       (cond ((fboundp 'console-type)        ;; XEmacs 19.14+
		      (or (and (equal (console-type) 'x)
			       gnuserv-frame
			       (frame-live-p gnuserv-frame))
			  (condition-case ()
			      (delete-frame (selected-frame)
					    server-kill-last-frame)
			    (error 
			     (message "Not deleting last visible frame...")))))
		     ((or (not window-system) 
			  (and gnuserv-frame 
			       (or (and (fboundp 'frame-live-p)
					(frame-live-p gnuserv-frame))
				   (and (fboundp 'live-screen-p)
					(live-screen-p gnuserv-frame))
				   (and (fboundp 'create-screen)
					(screenp gnuserv-frame)))))
		      ())                                   ;; do nothing
		     ((fboundp 'delete-frame)
		      (delete-frame (selected-frame) t))
		     ((fboundp 'delete-screen)
		      (delete-screen))))
      (error 
       "(server-edit): Use only on buffers created by external programs.")
      )))

(defun server-switch-buffer-internal (next-buffer always)
  "Switch to NEXT-BUFFER if a live buffer, otherwise switch to another buffer
with gnuserv clients. If no such buffer is available, we switch to
another normal buffer if `always' is non-nil!"
  ;; switching 
  (if next-buffer
      (if (and (bufferp next-buffer)
	       (buffer-name next-buffer))
	  (switch-to-buffer next-buffer)
	;; If NEXT-BUFFER is a dead buffer,
	;; remove the server records for it
	;; and try the next surviving server buffer.
	(server-switch-buffer-internal
	 (server-buffer-done next-buffer) always))
      (if server-clients
	  (server-switch-buffer-internal (nth 1 (car server-clients)) always)
	(if always
	    (switch-to-buffer (other-buffer))))))

;; For compatability
(defun server-switch-buffer (next-buffer)
  (server-switch-buffer-internal next-buffer t))

;; The below function calles server-done and switches to the next
;; sensible buffer. This implementation works regardless of the values
;; of server-*-function and doens't need the tail recursion
;; variable passing of server.el. It is more transparant too. JV
(defun server-done-and-switch ()
  "Be done with the current buffer and switch to another server buffer
  if there is one, otherwise just switch buffer"
  (let ((old-current (current-buffer)))
    (server-switch-buffer-internal (server-done) nil)
    (if (eq old-current (current-buffer))
	(switch-to-buffer (other-buffer)))))

(global-set-key "\C-x#" 'server-edit)

(provide 'gnuserv)

;;; gnuserv.el ends here
