;;; XTERM --- connect to an xterm X window

;;; Bruce Krulwich <krulwich@ils.nwu.edu> 30.12.1991
;;; Bruno Haible <haible@ma2s2.mathematik.uni-karlsruhe.de> 4.1.1994

;; (XTERM:OPEN name &key display geometry title) creates an XTERM window.
;; arguments:
;;       NAME -- a symbol naming the window
;; keywords:
;;       DISPLAY -- X display for the window
;;       GEOMETRY -- X geometry for the window
;;       TITLE -- X title displayed when the window is created
;;                (should be able to have titlebars somehow)
;; Return value:
;;       a bidirectional stream to the XTERM window.

;; (XTERM:FIND name)
;; arguments:
;;       NAME -- a symbol naming the window
;; Return value:
;;       the bidirectional stream to the XTERM window that has this name,
;;       or NIL.

;; (XTERM:NAME window)
;; arguments:
;;       WINDOW -- stream to an XTERM window.
;; Return value:
;;       its name or NIL

;; (XTERM:KILL window) kills an XTERM window
;; argument:
;;       WINDOW -- stream to an XTERM window.

;; (XTERM:LIST-ALL-WINDOWS)
;; Return value:
;;       list of current XTERM windows

;; (XTERM:BROADCAST format-string &rest args)
;; broadcasts a message to every XTERM window.

(defpackage "XTERM"
  (:export "OPEN" "FIND" "NAME" "KILL" "LIST-ALL-WINDOWS" "BROADCAST")
  (:shadow "OPEN" "FIND")
)

(in-package "XTERM")

; A list of triples (name window-stream pid) of all XTERM windows.
(defvar *xterm-list* '())

(defun open (name &key (display nil) (geometry nil) (title nil) (font nil)
                       (xterm-args nil)
            )
  (when (lisp:find name *xterm-list* :key #'first :test #'equal)
    (error "~S: There is already an XTERM window named ~S." 'open name)
  )
  ; generate a unique filename
  (let ((filename (gen-tmp-filename)))
    ; start xterm
    (multiple-value-bind (bi-stream in-stream out-stream)
        (run-program
          "xterm"
          :arguments
            `(,@(if display `("-display" ,(string display)))
              ,@(if geometry `("-geometry" ,(string display)))
              ,@(if title `("-title" ,(string title)) `("-title" ,(string name)))
              ,@(if font `("-font" ,(string font)))
              "-si"
              "-sl" "200"
              ,@xterm-args
              "-e" "xterm_idle" ,filename
             )
          ; We don't communicate directly with the xterm process but we
          ; specify :stream to let it run concurrently.
          :input :stream :output :stream
        )
      (let ((pid
              (parse-integer
                (remove-if-not #'digit-char-p
                  (write-to-string in-stream :base 10 :radix nil :readably nil)
           )) ) )
        (close in-stream)
        (close out-stream)
        (close bi-stream)
        ; Now wait until filename exists and contains an entire line:
        (let ((ttyname
                (loop
                  (when (probe-file filename)
                    (with-open-file (stream filename :direction :input)
                      (multiple-value-bind (first-line eof-p)
                          (read-line stream nil nil)
                        (when (and first-line (not eof-p))
                          (return first-line)
             )) ) ) ) ) )
          ; We can now delete the file.
          (delete-file filename)
          ; Create a bidirectional stream to the XTERM window via the tty:
          (let ((stream (lisp:open ttyname :direction :io)))
            (push (list name stream pid) *xterm-list*)
            stream ; That's it!
) ) ) ) ) )

(defun gen-tmp-filename (&optional (prefix "/tmp/clisp_") (length 8))
  (loop
    (let ((filename
            (let ((l '()))
              (dotimes (i length) (push (+ (char-code #\a) (random 26)) l))
              (concatenate 'string prefix (map 'string #'code-char l))
         )) )
      (unless (probe-file filename) (return filename))
) ) )

(defun xterm:find (name)
  (second (lisp:find name *xterm-list* :key #'first :test #'equal))
)

(defun xterm:name (stream)
  (first (lisp:find stream *xterm-list* :key #'second))
)

(defun xterm:kill (stream)
  (let ((info (lisp:find stream *xterm-list* :key #'second)))
    (when info
      (run-shell-command (format nil "kill -9 ~D" (third info)))
      (setq *xterm-list* (delete stream *xterm-list* :key #'second))
) ) )

(defun xterm:list-all-windows ()
  (mapcar #'second *xterm-list*)
)

(defun xterm:broadcast (format-string &rest args)
  (apply #'format (apply #'make-broadcast-stream (xterm:list-all-windows))
                  format-string args
) )

