;;;
;;; Functions for emacs server management.
;;;
;;; ----------------------------------------------------------------------
;;; This file is part of ILOG Talk.
;;; Inquiries to ILOG S.A.
;;;              9 rue de Verdun, BP 85,
;;;              94253 Gentilly Cedex, France.
;;;
;;; Copyright (c) 1993-1996 by ILOG
;;; ----------------------------------------------------------------------
;;;
;;; Name prefixes:
;;;
;;; ts		General prefix for emacs server mode identifiers.
;;;
;;; tsl:	Buffer-specific variables which are relative to emacs
;;; 		server processes.
;;;
;;; tsp:	Server buffer specific functions and variables.
;;; 		Can be called or referenced only when the current buffer
;;; 		is a server process buffer.
;;;


(require 'talk-mode)
(require 'talk-process)

(if emacs19p
    (require 'talk-server19)
  (require 'talk-server18))


;; Global variables
;; ----------------
;;

(defvar ts:server-buffer-format "*Talk%s*"
  "Name of the Talk server buffer.")

(defvar ts:bridge-server-name
  (if (eq system-type 'windows-nt) "iltserver.exe" "iltserver")
  "Name of the bridge server executable.")

(defvar ts:previous-text-buffer ()
  "Last selected text buffer before switching to emacs server buffer.")

(defvar ts:current-server ()
  "The current emacs server process.")

(defvar ts:current-bridge-server ()
  "The current bridge server process.")

(defvar ts:communication-buffer-name "*<Talk communication>*"
  "Name of the buffer used temporarily to deal with the communication file.")

(defvar ts:error-buffer-name "*Error*"
  "Name of the buffer used to show Talk errors")

(defvar ts:talk-data-buffer-name " *Talk data*"
  "Name of the buffer used to store Talk data.")

(defvar ts:current-server-p-truth-value " <current>"
  "Value used for tsp:current-server-p when it is true.")


;; Buffer specific variables
;; -------------------------
;;

;; If the buffer is attached to a server, contains that server process,
;; otherwise ().
(make-variable-buffer-local 'tsl:emacs-server)
(set-default 'tsl:emacs-server ())

;; If the buffer is attached to a bridge server, contains that bridge server
;; process, otherwise ().
(make-variable-buffer-local 'tsl:emacs-bridge-server)
(set-default 'tsl:emacs-bridge-server ())

;; If the buffer is or used to be a server buffer
;;
(make-variable-buffer-local 'tsl:emacs-server-buffer-p)
(set-default 'tsl:emacs-server-buffer-p ())


;; Key maps
;; --------
;;

(define-key tp:talk-process-map "\C-cs" 'tsp:select-as-current-server)
(define-key tm:talk-mode-map "\C-c\C-c" 'ts:send-current-process-interrupt)


;; Server process creation
;; -----------------------
;;

(defun run-talk (&optional command)
  "Start a Talk process."
  (interactive)
  (if (and (eq system-type 'windows-nt)
           (not (equal (getenv "OS") "Windows_NT"))
           (not (y-or-n-p "Talk/Emacs connection does not work under Win95. Continue? ")))
    ()
    (cond
      ((null command)
       (ts:read-command-run-server))
      ((not (stringp command))
       (error "Wrong type argument: stringp, %S" command))
      (t
       (ts:run-server command)))))

(defun ts:read-command-run-server ()
  "Read a command and launch Talk using this command."
  (catch 'abort
    (let ((command (read-string "Talk command: " tp:launch-command)))
      (cond
       ((string= command "")
	(if (not
	     (y-or-n-p
	      "Empty command; no Talk process will be launched. Confirm "))
	    (throw 'abort ())
	  (ts:run-server ())))
       (t
	(ts:run-server command))))))

(defun ts:run-server (talk-command)
  "Start an emacs server. If RUN-TALK-COMMAND is not (), a Talk process is
also launched using this command."
  (setq tp:launch-command talk-command)
  (let ((buffer (ts:get-new-server-buffer)))
    (set-buffer buffer)
    (goto-char (point-max))
    (let ((bol (progn (beginning-of-line) (point))))
      (goto-char (point-max))
      (if (not (= bol (point-max)))
	  (newline)))
    (if (not (= (point-min) (point-max)))
	(progn
	  (insert-char ?= (1- (screen-width)))
	  (newline)))
    (if talk-command
	(progn
	  (insert "$ " talk-command)
	  (newline)))
    (setq tsl:emacs-server-buffer-p t)
    (tsp:server-buffer-mode)
    (tsp:enter-state 'synchro)
    (setq tsp:manage-fn 'ts:manage-port-number)
    (setq tsp:port-number ())
    (setq tsl:emacs-bridge-server
      (start-process "emacs-bridge-server" buffer ts:bridge-server-name))
    (set-process-filter tsl:emacs-bridge-server 'ts:connection-filter)
    (set-process-sentinel tsl:emacs-bridge-server 'ts:bridge-server-sentinel)
    (setq ts:current-bridge-server tsl:emacs-bridge-server)
    (while (and (null tsp:port-number) 
                (not (null tsl:emacs-bridge-server))
		(not (tm:process-dead-p tsl:emacs-bridge-server)))
      (accept-process-output tsl:emacs-bridge-server))
    (if (null tsp:port-number)
	(error "cannot launch %s" ts:bridge-server-name))
    (setq tsp:manage-fn 'ts:manage-tcp-address)
    (let* ((system (tm:system-name))
	   (port (int-to-string tsp:port-number))
	   (options (concat "-emacs " system " " port)))
      (if talk-command 
	  (tpp:run-talk talk-command options)
	(insert (format "<emacs server started on host %s, port %s>" 
			system port))
	(newline)
	(insert (format
		 "To connect to this server, either:
- Run a new Talk executable with the option '%s'
- Call (emacs-connect \"%s\" %s) in a running Talk session."
		 options system port))
	(newline)
	(setq buffer-read-only t)
	(tm:show-buffer buffer)))))

(defun tm:system-name ()
  "Return the system name. On XEmacs 19.12, the domain name is
appended, so we remove it."
  (let* ((s (system-name))
	 (i (string-match "\\." s)))
    (if (null i)
	s
      (substring s 0 i))))

(defun ts:get-new-server-buffer ()
  "Return a buffer for a new process, trying to reuse server buffers with
dead processes, and then creating a new buffer."
  (let ((buffers (buffer-list))
	(found ()))
    (while (and buffers (null found))
      (let ((buffer (car buffers)))
	(if (and (ts:emacs-server-buffer-p buffer)
		 (or (null (get-buffer-process buffer))
		     (tm:process-dead-p (get-buffer-process buffer))))
	    (setq found buffer)
	  (setq buffers (cdr buffers)))))
    (if found
	(save-excursion
	  (set-buffer found)
	  (while (get-buffer-process found)
	    (delete-process (get-buffer-process found)))
	  (setq buffer-read-only ())
	  (if (tp:talk-process-buffer-p found)
	      (tpp:make-buffer-writable))
	  (if tp:erase-buffer-p
	      (erase-buffer))
	  (kill-all-local-variables)
	  found)
      (let ((count (tm:new-buffer-count ts:server-buffer-format)))
	(get-buffer-create
	 (tm:formatted-buffer-name ts:server-buffer-format count))))))


;; Bridge process
;; --------------
;;

(defun ts:bridge-server-sentinel (bridge-server status-string)
  "Called when a bridge server process status changes."
  (if (eq tsl:emacs-bridge-server ts:current-bridge-server)
      (setq ts:current-bridge-server ()))
  (setq tsl:emacs-bridge-server ())
  (let ((buffer (process-buffer bridge-server)))
    (if (buffer-name buffer)
	(save-excursion
	  (set-buffer buffer)
	  (setq tsl:emacs-bridge-server ())))))

(defun ts:manage-port-number (tsrv:process tsrv:output)
  (setq tsp:port-number (string-to-int tsrv:output)))

(defun ts:manage-tcp-address (tsrv:process tsrv:output)
  "Delete the current emacs server and open a network stream,
which is supposed to more liable."
  (let* ((pair (car (read-from-string tsrv:output)))
	 (hostname (car pair))
	 (port (cdr pair)))
    (delete-process tsl:emacs-bridge-server)
    (setq tsl:emacs-bridge-server ())
    (setq tsl:emacs-server
      (open-network-stream "talk-stream" (current-buffer) hostname port))
    (set-process-sentinel tsl:emacs-server 'ts:server-sentinel)
    (set-process-filter tsl:emacs-server 'ts:connection-filter)
    (ts:select-server-as-current tsl:emacs-server)
    (setq tsp:manage-fn 'ts:emacs-manage-output)))


;; Setup
;; -----
;;

(defun tsp:server-buffer-mode ()
  "Set all the buffer local variables for the server process."
  (tsp:emacs-server-variables)
  (tsp:emacs-server-specific-variables))

(defun tsp:emacs-server-variables ()
  "Create server buffer variables."

  (setq buffer-auto-save-file-name ())
  (buffer-flush-undo buffer)
  
  ;; True when a Talk expression has been succesfully received.
  (make-local-variable 'tsp:receivedp)
  (setq tsp:receivedp ())

  ;; True when a connection with Talk is established
  (make-local-variable 'tsp:connectedp)
  (setq tsp:connectedp ())

  ;; When an error has occured during the reception of a Talk expression,
  ;; contains an error message.
  (make-local-variable 'tsp:errorp)
  (setq tsp:errorp ())

  ;; Set to true by Talk when he want Emacs to show the data buffer file
  ;; when an error occurs.
  (make-local-variable 'tsp:error-as-data-p)
  (setq tsp:error-as-data-p ())
  
  ;; T if the server attached to the buffer is selected as the current
  ;; server. Used for the mode line.
  (make-local-variable 'tsp:current-server-p)
  (set-default 'tsp:current-server-p ())

  (setq mode-line-process '(": %s" tsp:current-server-p)))


;; Talk to Emacs
;; -------------
;;

(defvar ts:number-digits 12
  "Number of decimal digits for numbers")

(defvar ts:synchro-string-length 50
  "Length of the string of X's used for synchro")

(defvar tsp:port-number ()
  "Port number associated to the server process.")

(defvar tsp:buffer ()
  "Buffer being received.")

(defvar tsp:buffer-to-read ()
  "Number of characters remaining to read.")

(defvar tsp:state ()
  "The current state of the server filter, as a symbol:
- synchro: we are currently waiting for the synchro string.
- synchro-string: we are reading the synchro string.
- length: we are currently reading a message length.
- contents: we are currently reading a message contents.")

(defvar tsp:manage-fn ()
  "The function to call on the received data, a symbol.")

(defun ts:reset-server ()
  "Reset the current server to mode length."
  (save-excursion
    (set-buffer (process-buffer (ts:get-current-server)))
    (tsp:enter-state 'length)))

(defun ts:connection-filter (tsrv:process tsrv:output)
  "Filter for a server process. All the functions called by
ts:connection-filter use a special prefix tsrv: so that they don't
interfer with variables used in code executed by management functions."
  (let ((inhibit-quit t)
	(tsrv:original-buffer (current-buffer)))
    (unwind-protect (progn
		      (set-buffer (process-buffer tsrv:process))
		      (tsp:filter-server-output 
		       (ts:clean-output-specific tsrv:output)))
      (set-buffer tsrv:original-buffer))))

(defun tsp:filter-server-output (tsrv:output)
  (let ((tsrv:len (length tsrv:output))
	(tsrv:index 0))
    (while (> tsrv:len tsrv:index)
      (cond
       ((eq tsp:state 'synchro)
	(let ((pos (string-match "X" tsrv:output tsrv:index)))
	  (if (null pos)
	      (setq tsrv:index tsrv:len)
	    (setq tsrv:index pos)
	    (setq tsp:state 'synchro-string)
	    (setq tsp:buffer-to-read ts:synchro-string-length))))
       ((eq tsp:state 'synchro-string)
	(let ((pos (string-match "X+" tsrv:output tsrv:index)))
	  (if (or (null pos)
		  (not (eq pos tsrv:index)))
	      (setq tsp:state 'synchro)
	    (let ((tsrv:available (min tsp:buffer-to-read
				       (- (match-end 0) pos))))
	      (setq tsp:buffer-to-read (- tsp:buffer-to-read tsrv:available))
	      (setq tsrv:index (+ tsrv:index tsrv:available))
	      (if (= tsp:buffer-to-read 0)
		  (tsp:exit-current-state))))))
       (t
	(let ((tsrv:available
	       (min tsp:buffer-to-read (- tsrv:len tsrv:index))))
	  (setq tsp:buffer
		(concat tsp:buffer
			(substring tsrv:output tsrv:index
				   (+ tsrv:index tsrv:available))))
	  (setq tsp:buffer-to-read (- tsp:buffer-to-read tsrv:available))
	  (setq tsrv:index (+ tsrv:index tsrv:available))
	  (if (= tsp:buffer-to-read 0)
	      (tsp:exit-current-state))))))))

(defun tsp:enter-state (strv:state &optional tsrv:info)
  "Enter the strv:state STATE, giving optional information INFO."
  (setq tsp:state strv:state)
  (setq tsp:buffer "")
  (setq tsp:buffer-to-read
	(cond
	 ((eq strv:state 'length) ts:number-digits)
	 ((eq strv:state 'contents) tsrv:info))))

(defun tsp:exit-current-state ()
  "Exit the current state: do the associated actions, and enter the next
state."
  (cond
   ((eq tsp:state 'length)
    (tsp:enter-state 'contents (string-to-int tsp:buffer)))
   ((eq tsp:state 'contents)
    (let ((tsrv:buffer tsp:buffer))
      (tsp:enter-state 'length)
      (funcall tsp:manage-fn tsrv:process tsrv:buffer)))
   ((eq tsp:state 'synchro-string)
    (tsp:enter-state 'length))))

(defun ts:emacs-manage-output (tsrv:process tsrv:output)
  "Management function called for the Talk process output once
the connection has been properly established."
  (cond
    ((string= tsrv:output ""))
    ((eq (aref tsrv:output 0) ?D)
     (save-window-excursion
       (set-buffer (get-buffer-create ts:talk-data-buffer-name))
       (let ((here (point-max)))
	 (goto-char here)
	 (insert tsrv:output)
	 (goto-char here)
	 (delete-char 1))))
    (t
     (condition-case tsrv:pair
	 (let ((tsrv:exp (car (read-from-string tsrv:output))))
	   (eval tsrv:exp))
       (error (ts:print-error-condition-message tsrv:pair))))))

(defun ts:print-error-condition-message (tsrv:pair)
  "Print the error message corresponding to PAIR. PAIR is a tsrv:pair
of the form (CONDITION . CONDITION-ARGS)."
  (let* ((condition (car tsrv:pair))
	 (message (get condition 'error-message))
	 (args (cdr tsrv:pair)))
    (message "Internal error: %s: %s" message args)))


;; Emacs entry points for Talk
;; ---------------------------
;;

(defun tsp:connected ()
  "First function called by Talk when the connection is established."
  (setq tsp:connectedp t)
  (if (not (tp:talk-process-buffer-p (current-buffer)))
      (let ((buffer-read-only ()))
	(goto-char (point-max))
	(insert "<emacs server connected to Talk>")
	(newline))))

(defun tsp:received ()
  "Function called by Talk once an emacs command has been successfuly
received."
  (setq tsp:receivedp t))

(defun tsp:error (message &optional error-as-data-p)
  "Function called by Talk to signal errors. If optional ERROR-AS-DATA-P is
true, the data buffer is supposed to contain a Talk error message."
  (setq tsp:errorp message)
  (setq tsp:error-as-data-p error-as-data-p))

(defun ts:warn (message)
  "Function called by Talk to signal a warning."
  (message "Warning: %s" message))


;; Emacs to Talk
;; -------------
;;

(defun ts:server-send-string (server string &optional datap)
  "Send the string STRING to the server server PROCESS. If optional DATAP is
true, the string is sent as data."
  (let ((len (length string)))
    (if datap
	(progn
	  (process-send-string server (ts:number-string (+ len 2)))
	  (process-send-string server "D")
	  (process-send-string server string)
	  (process-send-string server "\n"))
      (process-send-string server (ts:number-string (1+ len)))
      (process-send-string server string)
      (process-send-string server "\n"))))

(defun ts:server-send-region (server buffer start end)
  "Send the region between START and END in BUFFER as data to SERVER."
  (let ((len (- end start)))
    (process-send-string server (ts:number-string (+ len 2)))
    (process-send-string server "D")
    (save-excursion
      (set-buffer buffer)
      (process-send-region server start end))
    (process-send-string server "\n")))

(defun ts:number-string (number)
  "Return a string representing NUMBER with ts:number-digits digits."
  (let* ((str (int-to-string number))
	 (len (length str)))
    (concat (make-string (- ts:number-digits len) ? ) str)))

(defun ts:asynch-remote-eval (form server)
  "Remote-evaluate FORM in SERVER and does not wait for any result."
  (save-excursion
    (set-buffer (process-buffer server))
    (message "Sending...")
    (ts:server-send-string server form)
    (message "Sending...done")))

(defun ts:remote-eval (form server &optional no-error-p)
  "Remote-evaluate FORM in SERVER and return T. Waits for either the
functions tsp:received or tsp:error to be called by Talk.
If a Talk error occurs, signal an error unless NO-ERROR-P is true; in
this case, just return ()."
  (let ((buffer (current-buffer)))
    (unwind-protect
	(let ((data-buffer (get-buffer-create ts:talk-data-buffer-name)))
	  (set-buffer data-buffer)
	  (erase-buffer)
	  (set-buffer (process-buffer server))
	  (message "Sending...")
	  (setq tsp:errorp ()
		tsp:receivedp ()
		tsp:error-as-data-p ())
	  (ts:server-send-string server form)
	  (while (not (or tsp:receivedp tsp:errorp))
	    (accept-process-output server)
	    (sit-for 0))
	  (cond
	   ((not tsp:errorp)
	    (message "Sending...done")
	    t)
	   (no-error-p
	    (message "Sending...%s" tsp:errorp)
	    ())
	   (t
	    (let ((errorp tsp:errorp)
		  (in-cfile-p tsp:error-as-data-p))
	      (if in-cfile-p
		  (ts:show-data-buffer ts:error-buffer-name))
	      (error "Talk error: %s" errorp)))))
      (set-buffer buffer))))


;; Server sentinel
;; ---------------
;;
      
(defun ts:server-sentinel (server status-string)
  (let ((buffer (process-buffer server)))
    (if (and (buffer-name buffer)
	     (or (not (tp:talk-process-buffer-p buffer))
		 (and tpl:talk-process
		      (not (tm:process-dead-p tpl:talk-process)))))
	(save-excursion
	  (set-buffer buffer)
	  (let ((buffer-read-only ()))
	    (goto-char (point-max))
	    (insert "<emacs server terminated>")))))
  (if (tm:process-dead-p server)
      (progn
	(delete-process server)
	(if (eq server ts:current-server)
	    (let ((new-server (car (ts:server-list))))
	      (if (and new-server (buffer-name (process-buffer new-server)))
		  (ts:select-server-as-current new-server)
		(ts:deselect-current-server)))))))

(defun tsp:kill-bridge-process ()
  "Kill the bridge server if it is not currently running."
  (if tsl:emacs-bridge-server
      (delete-process tsl:emacs-bridge-server)))

(defun ts:send-current-process-interrupt ()
  "If the current server has an associated process, send it an interruption."
  (interactive)
  (let* ((server (ts:get-current-server))
	 (process (ts:get-server-talk-process server)))
    (if process
	(tp:interrupt-process process))))


;; The data buffer
;; ---------------
;;

(defun ts:show-data-buffer (name)
  "Show the data buffer as a buffer named NAME and delete it."
  (let ((buffer ()))
    (if (setq buffer (get-buffer name))
	(save-excursion
	  (set-buffer buffer)
	  (erase-buffer)
	  (insert-buffer (get-buffer-create ts:talk-data-buffer-name))
	  (kill-buffer (get-buffer ts:talk-data-buffer-name)))
      (save-excursion
	(set-buffer (get-buffer-create ts:talk-data-buffer-name))
	(rename-buffer name)
	(talk-mode)
	(setq buffer (current-buffer))))
    (tm:show-buffer buffer () () 'begin)))

(defun ts:insert-data-buffer (start end)
  "Insert the contents of the data buffer as a replacement for the expression
between START and END."
  (goto-char start)
  (delete-region start end)
  (insert-buffer (get-buffer ts:talk-data-buffer-name)))

(defun ts:read-from-data-buffer ()
  "Read the first Talk expression in the data buffer."
  (save-excursion
    (set-buffer (get-buffer-create ts:talk-data-buffer-name))
    (goto-char (point-min))
    (tm:talk-read)))


;; Sending data
;; ------------
;;

(defun ts:send-form (process package buffer start end)
  "Send to PROCESS the PACKAGE and the region between START and END, as data."
  (message "Sending...")
  (if (eq package 'unknown)
      (ts:server-send-string server "()" t)
    (ts:server-send-string server package t))
  (ts:server-send-region server buffer start end))

	
;; Current server selection
;; ------------------------
;;

(defun ts:select-server-as-current (server)
  "Select SERVER as the current server."
  (ts:deselect-current-server)
  (let ((buffer (process-buffer server)))
    (save-excursion
      (set-buffer buffer)
      (setq tsp:current-server-p ts:current-server-p-truth-value)))
  (setq ts:current-server server))

(defun ts:deselect-current-server ()
  "Deselect the current server."
  (if ts:current-server
      (let ((buffer (process-buffer ts:current-server)))
	(if (buffer-name buffer)
	    (save-excursion
	      (set-buffer buffer)
	      (setq tsp:current-server-p ())))))
  (setq ts:current-server ()))

(defun ts:get-current-server (&optional no-error-p)
  "Return the current server. If there is no current server, or if
its buffer is killed, signal an error unless optional NO-ERROR-P is t;
in this case, just return ()."
  (cond
   ((and ts:current-server (buffer-name (process-buffer ts:current-server)))
    ts:current-server)
   (no-error-p ())
   (ts:current-bridge-server (error "Talk process not yet connected."))
   (t (error "No Talk process."))))

(defun ts:switch-text-server ()
  "If in a text buffer, switch to the current server buffer, or launch a
server it if there is no running one. If in a process server, switch to the
previous text buffer."
  (interactive)
  (cond
    (tsl:emacs-server-buffer-p
     (cond
       ((and (null tsl:emacs-bridge-server)
	     (or (null tsl:emacs-server)
		 (tm:process-dead-p tsl:emacs-server)))
	 (ts:read-command-run-server))
       ((and ts:previous-text-buffer
	     (buffer-name ts:previous-text-buffer))
	(tm:show-buffer ts:previous-text-buffer () t))
       (t (tm:other-window))))
    (t
     (setq ts:previous-text-buffer (current-buffer))
     (let ((buffer (or (and ts:current-server
			    (process-buffer ts:current-server))
		       (and ts:current-bridge-server
			    (process-buffer ts:current-bridge-server)))))
       (if (and buffer (buffer-name buffer))
	   (tm:show-buffer buffer buffer t 'end)
	 (ts:read-command-run-server))))))

(defun tsp:select-as-current-server ()
  "Select the emacs server attached to the current buffer as the current
server. Useful when several Talk processes are running."
  (interactive)
  (if (null tsl:emacs-server)
      (error "Not in a Talk buffer"))
  (ts:select-server-as-current tsl:emacs-server))


;; Utilities
;; ---------
;;

(defun ts:emacs-server-buffer-p (buffer)
  "Return T if BUFFER is a server buffer."
  (save-excursion
    (set-buffer buffer)
    tsl:emacs-server-buffer-p))

(defun ts:show-server-process-buffer (server)
  "If SERVER has an associated Talk process, show its buffer."
  (let ((process (ts:get-server-talk-process server)))
    (if process
	(let ((buffer (process-buffer process)))
	  (tm:show-buffer buffer () () 'end)))))

(defun ts:get-server-talk-process (server)
  "Return server's associated Talk process if it has one, or ()
otherwise."
  (let ((buffer (process-buffer server)))
    (if (and buffer (buffer-name buffer))
	(save-excursion
	  (set-buffer buffer)
	  tpl:talk-process))))

(defun ts:server-list ()
  "Return the list of all the running servers."
  (let ((l (process-list))
	(r ()))
    (while l
      (let ((p (car l)))
	(if (and (ts:server-process-p p)
		 (not (tm:process-dead-p p)))
	    (setq r (cons p r)))
	(setq l (cdr l))))
    (nreverse r)))

(defun ts:server-process-p (process)
  "Test whether PROCESS is a Talk process."
  (string-match "^emacs-server" (process-name process)))

(provide 'talk-server)
