;; kltk
;; a try at a simplistic interface to Tk a la Wafe, i.e. by forking a 
;; standard wish (tix?) process and dialoguing with it by input-output

(setq *package* "kltk")

(defvar kltk:wish-name "wish")		;name of interpreter
(defvar kltk:out ())			;read info from wish process
(defvar kltk:in ())			;write commands to wish process
(defvar kltk:pid ())			;PID of subprocess
(defvar kltk:timeout (* 300 1000))	;in milliseconds per command

;; errors
(defvar Errors:kltk:timeout "wish did not answer (timeout)")
(defvar Errors:kltk:tcl-error "TCL ERROR: %0")

;;internal use
(setq kltk::is-in-callback-func? ())	;wish waiting for result?

;;=============================================================================
;;                    debug
;;=============================================================================
;;AUTOLOAD: kltk:debug
;;AUTODOC: kltk:debug debugging mode for kltk wish inteface
;;
;;(kltk:debug t) synchronise calls to trap errors early
;;(kltk:debug ()) normal, faster operation
;;(kltk:debug) returns t or () if debugging mode is on or off

(defun kltk:debug (&optional (flag :query))
  (if (= :query flag)
    (setq flag (if (= kltk:call kltk:send) t ()))
    
    flag
    (if (= kltk:call kltk:send) ()
      (progn
	(setq kltk:debug:old-send kltk:send)
	(setq kltk:send kltk:call)
    ))
    (if (= kltk:call kltk:send)
      (setq kltk:send kltk:debug:old-send)
    )
  )
  flag
)

;;=============================================================================
;;                    initialisations
;;=============================================================================

(defun kltk:init ()
  (unless
    (and (boundp 'kltk:pid) kltk:pid (typep kltk:pid ProcessId) ;defined
      (not (wait kltk:pid :blocking ())) ;still alive?
    )
    (setq kltk:pid (system (list kltk:wish-name)	;else start it
	:input 'kltk:in
	:output 'kltk:out
	:error 'kltk:out
    ))
    (stream-mode kltk:out :blocking ())
    ;; init code for callbacks
    (PF kltk:in 
      "proc klone-send args {puts {(kltk:callback}
foreach i $args {puts $i} ; puts {)} ; flush stdout
}
proc klone-call args {puts {(kltk:callback-func}
foreach i $args {puts $i} ; puts {)} ; flush stdout
subst [gets stdin]
}
")
    (flush kltk:in)
))
(kltk:init)

(setq kltk::re-receive (regcomp "[(]kltk:callback"))

;;=============================================================================
;;                    end
;;=============================================================================

(defun kltk:end ()
  (kltk:send "exit")
  (kltk:flush)
)

;;=============================================================================
;;                    sending code to forked wish
;;=============================================================================

(setq kltk::send-format "puts {[(-<}
if [catch { %0 } klonemsg] {puts KLONE-ERROR; puts $klonemsg} {puts $klonemsg}
puts {>-)]}
")
(setq kltk::re-result (regcomp "^(.*)[[][(]-<\n(.*)\n>-[)][]]\n(.*)$"))
(setq kltk::re-error (regcomp "^(.*)[[][(]-<\nKLONE-ERROR\n(.*)\n>-[)][]]\n(.*)$"))

;synchronous 

;;AUTOLOAD: kltk:call
;;AUTODOC: kltk:call "calls commands to a tcl/tk (wish) subshell"
;; (kltk:call strings)
;;
;; Sends strings (blank-separated) to a wish subprocess which is forked if 
;; needed, waits for execution and return the result (string)
;; see kltk:send for a much faster function that does not wait for command 
;; result
;; callbacks are set by calling from wish the command: klone-callback, see
;; kltk:receive

(defun kltk:call (&rest args &aux
    (string (if
	(= 0 (length args)) ""
	(= 1 (length args)) (0 args)	;concat args
	(with (s (copy "")) (dolist (a args) (nconc s a " ")) s)
    ))
    answers
    result
    (returned-string "")
  )
  (if kltk::is-in-callback-func? (progn 
      (write-string "\n" kltk:in)(flush kltk:in)
      (setq kltk::is-in-callback-func? ())
  ))
  (catch 'EOP				;traps unexpected death of son
    (PF kltk:in kltk::send-format string)
    (flush kltk:in)
    (setq result t)
  )
  (if (not result) (progn		;dead? re-launch and retry once
      (kltk:init)
      (PF kltk:in kltk::send-format string)
      (flush kltk:in)
  ))
  (kltk:sync)
  ;; awaits answers
  (setq answers (getn (select kltk:out :timeout kltk:timeout) 0))
  (if (not answers)			;timeout
    (error 'Errors:kltk:timeout)
  )
  (catch 'EOF 
    (setq result (read-chars () kltk:out))
    (while (not (regexec kltk::re-result result))
      (if (not (setq answers 
	    (getn (select kltk:out :timeout kltk:timeout) 0)))
	(error 'Errors:kltk:timeout)
      )
      (setq result (read-chars () kltk:out))
      (nconc result (read-chars () kltk:out))
  ))
  (if (= "" result) ()
    (regexec kltk::re-error result)
    (kltk::error-handler (regsub kltk::re-error 2))

    (regexec kltk::re-result result) (progn
      (setq returned-string (regsub kltk::re-result 2))
      (write-string (+ (regsub kltk::re-result 1) (regsub kltk::re-result 3)))
    )
    ;; else
    (write-string result)
  )
  returned-string
)

;; asynchronous

;;AUTOLOAD: kltk:send
;;AUTODOC: kltk:send "sends commands to a tcl/tk (wish) subshell"
;; (kltk:send strings)
;;
;; Sends strings (blank-separated) to a wish subprocess which is forked if 
;; needed

(defun kltk:send (&rest args &aux
    (string (if
	(= 0 (length args)) ""
	(= 1 (length args)) (0 args)
	(with (s (copy "")) (dolist (a args) (nconc s a " ")) s)
    ))
    answers
    result
    (returned-string "")
  )
 (if kltk::is-in-callback-func? (progn 
      (write-string "\n" kltk:in)(flush kltk:in)
      (setq kltk::is-in-callback-func? ())
  ))
   (catch 'EOP    
    (write-string string kltk:in)
    (write-string "\n" kltk:in)
    (setq result t)
  )
  (if (not result) (progn
      (kltk:init)
      (write-string string kltk:in)
      (write-string "\n" kltk:in)
  ))
)

(defun kltk:flush () (flush kltk:in))
(defun kltk:sync ()
  (write-string "\nflush stderr\nflush stdout\n" kltk:in)
  (flush kltk:in)
)

;;=============================================================================
;;                    error handler
;;=============================================================================

(defun kltk::error-handler (text &aux res
  )
  (if (/= :nil (setq res (apply kltk:error-handler (list text))))
    res
    (error 'Errors:kltk:tcl-error text)
))

;; user-redefinable one

(if (not (boundp 'kltk:error-handler))
  (defun kltk:error-handler (text) :nil)
)

;;=============================================================================
;;                    receive data
;;=============================================================================

(defun kltk:receive (&optional (fd kltk:out) &aux
    answers
    result
    returned-expr
  )
  (catch 'EOF 
    (setq result (read-chars () fd))
    (while (not (regexec kltk::re-receive result))
      (if (not (setq answers 
	    (getn (select fd  :timeout kltk:timeout) 200)))
	(if (/= "" result)		;error
	  (throw 'EOF)
	  (wait kltk:pid :blocking ())	;died
	  (throw 'EOF)
	  (error 'Errors:kltk:timeout)	;timeout
      ))
      (setq result (read-chars () fd))
      (nconc result (read-chars () fd))
  ))
  (if (not result) () (= "" result) ()
    (regexec kltk::re-receive result) 
    (catch 'EOF
      (with (kltk:fd (Stream result))
	(while t
	  (eval (read kltk:fd))
    )))
    ;; rest? print it...
    (PF *standard-error* "kltk: wish sent: %0\n" result)
))

(defunq kltk:callback (&optional func &rest args)
  (apply func args)
)

(defunq kltk:callback-func (&optional func &rest args)
  (with (kltk::is-in-callback-func? t
      result (String (apply func args))
    )
    (if kltk::is-in-callback-func?	;no broken by inside send?
      (progn
	(PF kltk:in "%l0\n" result)
        (flush kltk:in)
      )					;else, beat it...
)))

;;AUTOLOAD: kltk:mainloop
;;AUTODOC: kltk:mainloop "main loop for kltk klone-to-wish"
;; this main loop just looks at the stream from the wish process and executes 
;; the callbacks called by the tcl function: klone-callback
;; in tcl: klone-callback a b c d
;; will call in klone (a b c d)
;; e.g: Button -text "go" -command "klone-callback go"
;;      creates a button that when pressed will call the klone expression: (go)
;; other streams can be given to mainloop as pairs (p-list) stream callback
;; callback being called with the stream as parameter
;; Exemple:
;; (kltk:send "button .b -text date -command {klone-callback print-date}
;;     pack .b")
;; (defun print-date () (PF "date is: %0\n" (cur-date)))
;; (kltk:mainloop)
;;
;; creates a button printing the date

(defun kltk:mainloop (&rest other-streams &aux
    fd 
    (fdlist (copy (vector kltk:out)))
  )
  (dohash (fd cb other-streams) (lappend fdlist fd))
  (while (not (wait kltk:pid :blocking ()))
    (kltk:flush)
    (kltk:sync)
    (setq fd (getn (getn (select fdlist) 0) 0))
    (apply (get other-streams fd kltk:receive)
      (list fd))
))

;;=============================================================================
;;                    convenient quoting func
;;=============================================================================

(defvar kltk:comma-symbol (intern ","))

(defunq tk (&rest kltk::args &aux
    (kltk::expansed-args (copy ()))
  )
  (dolist (kltk::arg kltk::args)
    (if 
      (and (typep kltk::arg QuotedExpr) 
	(= kltk:comma-symbol (get kltk::arg 0)))
      (setq kltk::arg (eval (get kltk::arg 1)))
      
      (typep kltk::arg String)
      ()

      (typep kltk::arg Int)
      (setq kltk::arg (String kltk::arg))

      (setq kltk::arg (String (eval kltk::arg)))
    )
    (lappend kltk::expansed-args kltk::arg)
  )
  (apply kltk:send kltk::expansed-args)
)
