I've got a beta version connecting Qi with TCL/tk which is type
secure. However there is this glitch that causes the interface to
hang. The hanging is cleared by the next command sent to TCL/tk,
which suggests to me that TCL/tk is waiting to receive an input.
Perhaps I have failed to close off something.
At any rate here is the relevant code which runs under virgin CLisp.
You need TCL/tk to run it and you need to change the line
(DEFCONSTANT *tk-prog* "C:/PROGRAM FILES/TCL/BIN/WISH83.EXE")
to where you hold your TCL/tk.
If you load it into CLisp, type
(talk "bell" (return-tk-stream T))
which should sound the bell. You may notice that a window called
'root' then appears which is now hung with an hourglass that appears
if you mouseover. This is the glitch. Repeat the command and the
hourglass disappears.
This hanging has cropped up now and again, and I'm wondering why.
Mark
_______________________________________________________________
"Author: Mark Tarver
Date: 23rd May, 2007
Platform: Clisp
Package: qi-tk (in final release)"
(PROCLAIM '(SPECIAL *tk-prog* *tk* *tk-args* *timeout*))
(SET-SYNTAX-FROM-CHAR #\; #\v)
(SETF (READTABLE-CASE *READTABLE*) :PRESERVE)
"Opens a bidirectional Stream to TCL/tk"
(DEFUN open-process-stream (CMD &OPTIONAL ARGUMENTS)
(SYSTEM::RUN-PROGRAM CMD
:ARGUMENTS ARGUMENTS
:INPUT :STREAM
:OUTPUT :STREAM))
"Where TCL/tk lives"
(DEFCONSTANT *tk-prog* "C:/PROGRAM FILES/TCL/BIN/WISH83.EXE")
"The name of the root window"
(DEFCONSTANT *tk-args* '("-name" "root"))
"Define *tk* as the multidirectional stream"
(DEFCONSTANT *tk* (open-process-stream *tk-prog* *tk-args*))
(DEFUN return-tk-stream (X) (DECLARE (IGNORE X)) *tk*)
"Sets the timeout"
(DEFUN timeout (N) (SETQ *timeout* N))
"All transactions are given at most 1 second to complete."
(timeout 1)
"Second version; looks for NIL case if read-tk-stream returns NIL
because of an error."
(DEFUN listen (Timeout Stream)
(PROG ((Start (GET-INTERNAL-RUN-TIME)))
LOOP
(IF (LISTEN Stream)
(LET ((String (read-stream-string Stream)))
(IF (OR (NULL String) (STRING= String ""))
(GO LOOP)
(RETURN String))))
(IF (timeout? (GET-INTERNAL-RUN-TIME) Start Timeout) (RETURN
""))
(GO LOOP)))
"Timed out if elapsed time exceeds timeout."
(DEFUN timeout? (Now Start Timeout)
(LET* ((Interval (- Now Start))
(TimeElapsed (/ Interval INTERNAL-TIME-UNITS-PER-SECOND)))
(> TimeElapsed Timeout)))
"Read characters to a string and trim off whitespace."
(DEFUN read-stream-string (Stream)
(IGNORE-ERRORS
(STRING-TRIM '(#\Newline #\Space)
(COERCE (read-exhausting Stream NIL) 'STRING))))
"Read until you can read no more."
(DEFUN read-exhausting (Stream Accum)
(LET ((CHAR (READ-CHAR-NO-HANG Stream NIL NIL)))
(IF (NULL CHAR)
(REVERSE Accum)
(read-exhausting Stream (CONS CHAR Accum)))))
"Flush the stream to get rid of any crap coming down to Lisp.
Then send a message to TCL/tk Use FINISH-OUTPUT to make sure
it goes through. Don't bother to listen for a reponse."
(DEFUN talk (String Stream)
(flush-stream Stream)
(FORMAT Stream "~A~%" String)
(FINISH-OUTPUT *tk*))
"Talk, but listen for what comes back."
(DEFUN talk-and-listen (String Timeout Stream)
(talk String Stream)
(listen Timeout Stream))
"Like listening, except no record is kept of what is heard.
Everything is discarded."
(DEFUN flush-stream (Stream)
(IF (LISTEN Stream)
(read-exhausting-discard Stream))
NIL)
"Read and forget."
(DEFUN read-exhausting-discard (Stream)
(COND ((NULL (READ-CHAR-NO-HANG Stream NIL NIL)))
(T (read-exhausting-discard Stream))))
"Listen and act on what you hear"
(DEFUN listen-and-act (Timeout Stream)
(LET ((String (listen Timeout Stream)))
(IF (commandstring? String)
(execute-command String)
String)))
"A command string is prefixed by @"
(DEFUN commandstring? (String)
(IF (STRING= String "")
NIL
(STRING= ·@" String :START2 0 :END2 1)))
"Remove the @, read the contents from the string and execute."
(DEFUN execute-command (String)
(eval (READ-FROM-STRING (STRING-LEFT-TRIM ·@" String))))
"Talk, listen for what comes back and act on it."
(DEFUN talk-listen-and-act (String Timeout Stream)
(talk String Stream)
(listen-and-act Timeout Stream))
"Macro for wrapping round Lisp commands to turn them into command
strings.
for communication to TCL/tk"
(DEFMACRO delay (X) (FORMAT NIL "puts ·@~S}; flush stdout" X))
"System command for communicating to the OS; returns a string"
(DEFUN system (Command)
(LET ((IFilename (FORMAT NIL "~A.bat" (gensym "file")))
(OFilename (FORMAT NIL "~A" (gensym "file"))))
(write-to-file IFilename Command)
(SYSTEM::RUN-PROGRAM IFilename :OUTPUT OFilename)
(DELETE-FILE IFilename)
(LET ((Output (COERCE (read-file-as-charlist OFilename) 'STRING)))
(DELETE-FILE OFilename)
Output)))