<|start_filename|>base.lisp<|end_filename|>
(in-package :cl-tk)

(define-condition tcl-error (simple-error) ())
(defun tcl-error (control &rest args)
  (error 'tcl-error :format-control control :format-arguments args))

(defvar *tk*)

(defclass tk ()
  ((event-table :initform (make-hash-table :test 'eql) :reader @table)
   (next-id :initform 0 :accessor @next-id)))

;; Event callback registration

(defun register-event (handler)
  (let ((id (@next-id *tk*)))
    (incf (@next-id *tk*))
    (setf (gethash id (@table *tk*)) handler)
    id))

(defun unregister-event (id)
  (remhash id (@table *tk*)))

(defun event-handler (func &optional (fields ()))
  (let ((id (register-event func)))
    (values (format nil "_ev ~a~{ %~a~}" id fields) id)))

(defmacro event-handler* (&body body)
  `(event-handler (lambda () ,@body)))

(defmacro bind-event (tag event (&rest fields) &body body)
  "For example (bind-event \".\" \"<1>\" ((x #\x) (y #\y)) (format t \"clicked ~a,~a\" x y))"
  `(multiple-value-bind (handler id) (event-handler (lambda ,(mapcar #'first fields) ,@body) ',(mapcar #'second fields))
     (tcl "bind" ,tag ,event handler)
     id))

(defun handle-event (tk id args)
  (let ((handler (gethash id (@table tk))))
    (if handler
        (apply handler args)
        (warn "Event '~a' fired, but no handler exists." id))))

(defun event-snapshot ()
  (@next-id *tk*))
(defun clear-events (snapshot)
  (let ((tab (@table *tk*)))
    (maphash (lambda (k v)
               (declare (ignore v))
               (when (>= k snapshot) (remhash k tab)))
             tab)
    (setf (@next-id *tk*) snapshot)))

(defmacro with-local-events (&body body)
  (let ((snap (gensym)))
    `(let ((,snap (event-snapshot)))
       (unwind-protect (progn ,@body)
         (clear-events ,snap)))))

;; Methods on tk objects

(defgeneric tk-destroy (tk))
(defgeneric tk-alive-p (tk))
(defun destroy () (tk-destroy *tk*))
(defun alive-p () (tk-alive-p *tk*))

(defgeneric tk-doevent (tk &optional block))
(defun doevent (&optional block) (tk-doevent *tk* block))
(defun doevents () (loop :while (doevent)))
(defun mainloop ()
  (loop :while (alive-p)
        :do (doevent t)))

(defgeneric tcl-send (tk command &optional get-result))

;; Tcl commands

(defun tcl-escape (str)
  (if (string= str "")
      "{}"
      (with-output-to-string (out)
        (loop :for ch :across str
              :do (princ (case ch
                           (#\newline "\\n") (#\tab "\\t") (#\backspace "\\b")
                           (#\page "\\f") (#\return "\\r") (#\vt "\\v") (#\bell "\\a")
                           ((#\" #\\ #\[ #\] #\$ #\space #\} #\{ #\;) (princ #\\ out) ch)
                           (t ch)) out)))))

(defstruct (literal-string (:constructor lit (val))) val)

(defun tcl-form (val)
  (etypecase val
    (keyword (format nil "-~a" (string-downcase (symbol-name val))))
    (string (tcl-escape val))
    (number (princ-to-string val))
    (literal-string (literal-string-val val))
    (list (format nil "~{~a~^ ~}" (mapcar #'tcl-form val)))))

(flet ((as-string (before after command args)
         (format nil "~a~a~{ ~a~}~a" before command (mapcar 'tcl-form args) after)))
  (defun tcl[ (command &rest args)
    (lit (as-string #\[ #\] command args)))
  (defun tcl{ (command &rest args)
    (lit (as-string #\{ #\} command args)))
  (defun tcl (command &rest args)
    (tcl-send *tk* (as-string "" "" command args))))

;; wnames

(defun wname-cons (name base)
  (format nil "~a.~a" (if (string= base ".") "" base) name))
(flet ((find-dot (name)
         (or (position #\. name :from-end t)
             (tcl-error "~a is not a valid wname" name))))
  (defun wname-car (name)
    (subseq name (1+ (find-dot name))))
  (defun wname-cdr (name)
    (subseq name 0 (max 1 (find-dot name)))))

(defvar *wname* ".")
(defmacro with-wname (name &body body)
  `(let ((*wname* ,name)) ,@body))
(defun wname (name &optional id)
  (wname-cons (if id (format nil "~a~a" name id) name) *wname*))

;; Running a Tk instance

(defun start-tk (&optional back-end)
  (or back-end
      (if (find-class 'ffi-tk)
          (handler-case (make-instance 'ffi-tk)
            (error (e) (warn "Failed to start FFI back-end: ~a" (princ-to-string e))
                       (make-instance 'wish-tk)))
          (make-instance 'wish-tk))))

(defmacro with-tk ((&optional back-end) &body body)
  `(let ((*tk* (start-tk ,back-end)))
     (unwind-protect (progn ,@body)
       (destroy))))

(defun toplevel-tk (&optional back-end)
  (setf *tk* (start-tk back-end)))


<|start_filename|>test.lisp<|end_filename|>
(in-package :cl-tk)

(defun test-button ()
  (with-tk ()
    (let ((stop nil))
      (tcl "ttk::button" ".b" :text "Exit ☻" :command (event-handler* (setf stop t)))
      (tcl "pack .b")
      (loop :while (alive-p)
            :do (doevent t)
            :do (when stop (destroy))))
    (mainloop)))


<|start_filename|>package.lisp<|end_filename|>
(defpackage :cl-tk
  (:use :cl)
  (:export #:tcl-error
           #:toplevel-tk #:with-tk #:*tk*
           #:tcl-escape #:lit #:tcl #:tcl[ #:tcl{
           #:wname-cons #:wname-car #:wname-cdr
           #:with-wname #:wname #:*wname*
           #:event-handler #:event-handler* #:unregister-event
           #:bind-event
           #:with-local-events #:event-snapshot #:clear-events
           #:doevent #:doevents #:mainloop
           #:wish-tk #:ffi-tk #:destroy #:alive-p))


<|start_filename|>wish.lisp<|end_filename|>
(in-package :cl-tk)

;; Some inspiration taken from <NAME>'s LTK project: http://www.peter-herth.de/ltk/

(defun wish-stream (binary-name)
  (or
   #+(or cmu scl)
   (let ((proc (run-program binary-name nil :input :stream :output :stream :wait nil
                            #+scl :external-format #+scl :utf-8)))
     (when proc
       (make-two-way-stream
        (ext:process-output proc)
        (ext:process-input proc))))

   #+clisp
   (ext:run-program binary-name :input :stream :output :stream :wait t)

   #+sbcl
   (let ((proc (sb-ext:run-program binary-name nil :input :stream :output :stream :wait nil :search t)))
     (when proc
       #+:ext-8859-1
       (make-two-way-stream
        (sb-sys:make-fd-stream (sb-sys:fd-stream-fd (process-output proc))
                               :input t :external-format :iso-8859-1)
        (sb-sys:make-fd-stream (sb-sys:fd-stream-fd (process-input proc))
                               :output t  :external-format :iso-8859-1))
       #-:ext-8859-1
       (make-two-way-stream (sb-ext:process-output proc) (sb-ext:process-input proc))))

   #+lispworks
   (system:open-pipe fullstring :direction :io)

   #+allegro
   (excl:run-shell-command binary-name :input :stream :output :stream :wait nil)

   #+ecl
   (ext:run-program binary-name nil :input :stream :output :stream :error :output)

   #+openmcl
   (let ((proc (ccl:run-program binary-name nil :input :stream :output :stream :wait nil)))
     (when proc
       (make-two-way-stream (ccl:external-process-output-stream proc)
                            (ccl:external-process-input-stream proc))))

   (tcl-error "Could not start wish process.")))

(defclass wish-tk (tk)
  ((stream :reader @stream)
   (binary :initarg :binary :initform '("wish8.5" "wish85" "wish") :reader @binary)
   (queue :initform () :accessor @queue)
   (alive :initform t :accessor @alive)))

(defun try-wish-binaries (binaries)
  (flet ((try-stream (stream)
           (format stream "puts {test}~%" stream)
           (finish-output stream)
           (unless (string= (read-line stream) "test") (error "NOPE"))))
    (dolist (binary binaries)
      (let ((stream (ignore-errors (wish-stream binary))))
        (when stream
          (handler-case (progn (try-stream stream)
                               (return stream))
            (error ())))))))

(defmethod initialize-instance :after ((tk wish-tk) &key &allow-other-keys)
  (let ((binaries (if (consp (@binary tk)) (@binary tk) (list (@binary tk)))))
    (setf (slot-value tk 'stream)
          (or (try-wish-binaries binaries)
              (tcl-error "Could not open Wish shell (tried ~{'~a'~^, ~})" binaries))))
  (tcl-send tk "package require Tk 8.5" nil)
  (tcl-send tk "proc _esc {s} {format {\"%s\"} [regsub -all {\"} [regsub -all {\\\\} $s {\\\\\\\\}] {\\\"}]}" nil)
  (tcl-send tk "proc _lst {type args} {puts \"(:$type\"; foreach arg $args {puts \" [_esc $arg]\"}; puts \")\\n\"; flush stdout}" nil)
  (tcl-send tk "proc _ev {args} {_lst e {*}$args}" nil)
  (tcl-send tk "proc _run {stat} {if [catch {set res [uplevel #0 $stat]} err] {_lst x $err} {_lst d $res}}" nil)
  (tcl-send tk "puts {}" nil)
  (let ((out (read-line (@stream tk))))
    (unless (string= out "")
      (if (and (> (length out) 33) (string= (subseq out 0 33) "version conflict for package \"Tk\""))
          (tcl-error "Incorrect Tcl/Tk version: ~a" out)
          (tcl-error "Tcl started with an unexpected message: ~a" out)))))

(defmethod tk-destroy ((tk wish-tk))
  (when (@alive tk)
    (ignore-errors (tcl-send tk "destroy ."))))

(defmethod tk-alive-p ((tk wish-tk))
  (@alive tk))

(defun read-wish-message (stream &optional type)
  (unless (eql (peek-char t stream) #\()
    (let ((junk (with-output-to-string (out)
                  (loop :for ch := (read-char-no-hang stream) :while ch
                        :if (eql ch #\() :do (progn (unread-char ch stream) (return))
                        :do (write-char ch out)))))
      (tcl-error "Junk in wish output: '~a'" junk)))
  (let ((expr (read-preserving-whitespace stream)))
    (unless (or (null type) (eq (car expr) type))
      (tcl-error "Unexpected message '~a' from wish." (car expr)))
    (values (cdr expr) (car expr))))

(defmethod tcl-send ((tk wish-tk) command &optional (get-result t))
  (let ((stream (@stream tk)))
    (handler-case (format stream (if get-result "_run {~a}~%" "~a~%") command)
      (error ()
        (setf (@alive tk) nil)
        (tcl-error "Wish process exited.")))
    (finish-output stream)
    (when get-result
      (loop :for (val type) := (multiple-value-list (read-wish-message stream))
            :do (ecase type
                  (:d (return (car val)))
                  (:x (tcl-error (car val)))
                  (:e (setf (@queue tk) (append (@queue tk) (list val)))))))))

(defun input-pending-p (stream)
  (loop :for ch := (read-char-no-hang stream)
        :if (not ch) :do (return nil)
        :if (graphic-char-p ch) :do (progn (unread-char ch stream)
                                           (return t))))

(defmethod tk-doevent ((tk wish-tk) &optional block)
  (let ((stream (@stream tk)))
    (handler-case
        (when (or block (input-pending-p stream))
          (destructuring-bind (id &rest args) (read-wish-message stream :e)
            (handle-event tk (parse-integer id) args))
          t)
      (end-of-file () (setf (@alive tk) nil)))))


<|start_filename|>ffi.lisp<|end_filename|>
(in-package :cl-tk)

(eval-when (compile eval load)
  (defconstant +tcl-ok+ 0)
  (defconstant +tcl-error+ 1)
  (defconstant +tcl-dont-wait+ 2))

(defclass ffi-tk (tk)
  ((interp :reader @interp)
   (alive :initform t :accessor @alive)))

(defmethod initialize-instance :after ((tk ffi-tk) &key &allow-other-keys)
  (handler-case (load-libs)
    (error (e) (tcl-error (princ-to-string e))))
  (let ((int (create-interp)))
    (when (null-pointer-p int) (tcl-error "Could not create interpreter."))
    (unless (and (= (tcl-init int) +tcl-ok+) (= (tk-init int) +tcl-ok+))
      (tcl-error "Initialising Tcl/Tk failed."))
    (setf (slot-value tk 'interp) int))
  (tcl-send tk "proc _esc {s} {format {\"%s\"} [regsub -all {\"} [regsub -all {\\\\} $s {\\\\\\\\}] {\\\"}]}")
  (tcl-send tk "set _events {}")
  (tcl-send tk "proc _ev {args} {global _events; foreach arg $args {append escaped [_esc $arg]}; lappend _events \"([concat $escaped])\"}")
  (tcl-send tk "proc _get_ev {} {global _events; set ret [lindex $_events 0]; set _events [lrange $_events 1 end]; set ret}")
  (let ((*tk* tk))
    (tcl-send tk (format nil "bind . <Destroy> {if [string match . %W] {~a}}" (event-handler* (tk-destroy tk))))
    (doevents)))

(defmethod tk-destroy ((tk ffi-tk))
  (when (@alive tk)
    (setf (@alive tk) nil)
    (delete-interp (@interp tk))))

(defmethod tk-alive-p ((tk ffi-tk))
  (@alive tk))

(defmethod tcl-send ((tk ffi-tk) command &optional (get-result t))
  (unless (@alive tk) (tcl-error "Tk instance no longer alive."))
  (case (tcl-eval (@interp tk) command)
    (#.+tcl-error+ (tcl-error (get-string-result (@interp tk))))
    (#.+tcl-ok+ (when get-result (get-string-result (@interp tk))))))

(defmethod tk-doevent ((tk ffi-tk) &optional block)
  (unless (@alive tk) (return-from tk-doevent nil))
  (when (= (do-one-event (if block 0 +tcl-dont-wait+)) 1)
    (loop :for result := (tcl-send tk "_get_ev")
          :until (string= result "")
          :do (let ((expr (read-from-string result)))
                (handle-event tk (parse-integer (car expr)) (cdr expr)))
          :unless (@alive tk) :do (return))
    t))


<|start_filename|>doc/index.html<|end_filename|>
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
  <head>
    <title>CL-TK</title>
    <style type="text/css">
      body { padding: 3em; max-width: 50em; }
      h1, h2 { margin-left: -1em; }
      h1 { font-size: 150%; border-bottom: 2px solid #1A8; }
      h2 { font-size: 130%; border-bottom: 1px solid #1A8; }
      h3 { font-size: 110%; }
      .def { font-family: monospace; font-weight: bold; }
      .def span { color: #AAA; font-family: sans-serif; font-size: 70%; }
      .desc { margin-left: 10pt; }
    </style>
    <meta http-equiv="Content-Type" content="text/html; charset=utf-8"/>
  </head>

  <body>
    <h1>CL-TK</h1>

    <p>CL-TK provides a very basic bridge to <a
    href="http://tcl.tk">Tcl/Tk</a>. It will fire up a Tk window,
    handle events, and allow you to evaluate Tcl code.</p>

    <h2>Contents</h2>

    <ul>
      <li><a href="#news">News</a></li>
      <li><a href="#download">Download and installation</a></li>
      <li><a href="#support">Support</a></li>
      <li><a href="#example">Examples</a></li>
      <li><a href="#reference">Reference</a>
        <ul>
          <li><a href="#back-ends">Back-ends</a></li>
          <li><a href="#evaluation">Tcl evaluation</a></li>
          <li><a href="#events">Event handling</a></li>
          <li><a href="#wnames">Window names</a></li>
          <li><a href="#errors">Errors</a></li>
        </ul>
      </li>
    </ul>

    <h2 id="news">News</h2>

    <p class="news"><em>25-11-2011:</em> <a
    href="http://marijnhaverbeke.nl/cl-tk/cl-tk-0.2.tgz">Version
    0.2</a>: Fixes several small issues in escaping and backend spawning.</p>

    <p class="news"><em>16-03-2009:</em> <a
    href="http://marijnhaverbeke.nl/cl-tk/cl-tk-0.1.tgz">Version
    0.1</a>: The first public release of this library.</p>

    <h2 id="download">Download and installation</h2>

    <p>This library is released under a zlib-style license, which
    approximately means you can use the code in whatever way you like,
    except for passing it off as your own or releasing a modified
    version without indication that it is not the original. See the
    LICENSE file in the distribution.</p>

    <p>CL-TK requires <a
    href="http://www.tcl.tk/software/tcltk/">Tcl/Tk</a> 8.5 to be
    installed. It also has an optional dependence on <a
    href="http://common-lisp.net/project/cffi/">CFFI</a> (on platforms
    other than Allegro Common Lisp). Not having CFFI installed means
    the FFI backend is not available, and you have to use the
    <code>wish</code> based backend, which is somewhat slower.</p>

    <p>The current release of CL-TK can be downloaded from <a
    href="http://marijnhaverbeke.nl/cl-tk/cl-tk.tgz">http://marijnhaverbeke.nl/cl-tk/cl-tk.tgz</a>,
    or installed with <a
    href="http://www.cliki.net/ASDF-Install">asdf-install</a>.</p>

    <p>A <a href="http://www.git-scm.com/">git</a> repository with the
    most recent changes can be checked out with:</p>

    <pre>&gt; git clone http://marijnhaverbeke.nl/git/cl-tk</pre>

    <p>The code is also available on <a href="http://github.com/marijnh/cl-tk">github</a>.</p>

    <h2 id="support">Support</h2>

    <p>There is currently no mailing list, so mail me <a
    href="mailto:<EMAIL>">directly</a>. I'll set something up when
    there is enough traffic.</p>

    <h2 id="example">Examples</h2>

    <p>To use CL-TK, a basic understanding of <a
    href="http://www.tcl.tk/man/tcl8.5/tutorial/tcltutorial.html">Tcl</a>
    and <a href="http://www.tkdocs.com/tutorial/index.html">Tk</a> is
    indispensable. If you are completely new to those, you might want
    to read up on them first.</p>

    <p>When working with Tk, the <code>*tk*</code> special variable
    has to be bound to a back-end object. The simplest way to do this
    is:</p>

    <pre>(toplevel-tk)</pre>

    <p>This will automatically create a suitable Tk back-end. See <a
    href="#back-ends">below</a> for details on what these back-ends
    are.</p>

    <p>You should now see an empty window. Next, we'll want to put
    something into this window:</p>

    <pre>(tcl "pack [ttk::label .label -text {Hello world}]")</pre>

    <p>Or, if you don't want to pass the whole command as one big
    string:</p>

    <pre>(tcl "pack" (tcl[ "ttk::label" ".label" :text "Hello world"))</pre>

    <p>See the <a href="#tcl">reference</a> for information about the
    way in which arguments to <a href="#tcl"><code>tcl</code></a> and
    <a href="#tcl_"><code>tcl[</code></a> are treated.</p>

    <p>Depending on your platform and back-end, it's possible that you
    don't see your label in the window yet. That's because it is not
    reacting to events. <a href="#mainloop"><code>mainloop</code></a>
    will run Tk's event pump until the window is closed.</p>

    <pre>(mainloop)</pre>

    <p>Another capability that this library provides is running Lisp
    code when Tk events occur. For example:</p>

    <pre>(with-tk ()
  (tcl "pack" (tcl[ "ttk::button" ".exit" :text "Exit" :command (event-handler #'destroy)))
  (mainloop))</pre>

    <p><a href="#with-tk"><code>with-tk</code></a> locally binds
    <code>*tk*</code>. The <a href="#destroy"><code>destroy</code></a>
    function (predictably) destroys the Tk instance. But what does <a
    href="#event-handler"><code>event-handler</code></a> do? Tk event
    handlers are pieces of Tcl code, not Lisp functions.
    <code>event-handler</code> returns a piece of code that, when
    executed, will notify the CL-TK event pump, which will call the
    function that was passed to <code>event-handler</code>. More about
    this <a href="#events">below</a>.</p>

    <h2 id="reference">Reference</h2>

    <h3 id="back-ends">Back-ends</h3>

    <p>There are two types of back-ends. It is never obligatory to
    specify a back-end, and when you don't the sensible thing happens:
    The system tries to use the faster FFI back-end, and falls back on
    <code>wish</code> when that fails.</p>

    <p class="def" id="ffi-tk">
      <span>class</span> ffi-tk
    </p>

    <p class="desc">Only available when you either have <a
    href="http://common-lisp.net/project/cffi/">CFFI</a> installed, or
    are using Allegro Common Lisp. A back-end that tries to load the
    Tcl and Tk shared libraries, and talk to them through a
    foreign-function interface.</p>

    <p class="def" id="wish-tk">
      <span>class</span> wish-tk
    </p>

    <p class="desc">This back-end starts a <code>wish</code>
    (windowing shell) process, and communicates with that through its
    standard in and output channels. You can specify a
    <code>:binary</code> initarg to specify the name (and optionally
    path) of the executable to run. This can be a single string or
    pathname, or a list of strings and pathnames.</p>

    <p class="def" id="tk">
      <span>variable</span> *tk*
    </p>

    <p class="desc">Holds the 'current' back-end. This is used by most
    of the function in the library. Bind with <a
    href="#toplevel-tk"><code>toplevel-tk</code></a> and <a
    href="#with-tk"><code>with-tk</code></a>.</p>

    <p class="def" id="toplevel-tk">
      <span>function</span> toplevel-tk (&amp;optional back-end)
    </p>

    <p class="desc">Set <a href="#tk"><code>*tk*</code></a> to a
    back-end. When no argument is given, the library tries to create a
    suitable back-end.</p>

    <p class="def" id="with-tk">
      <span>macro</span> with-tk ((&amp;optional back-end) &amp;body body)
    </p>

    <p class="desc">Execute <code>body</code> with <a
    href="#tk"><code>*tk*</code></a> bound to a back-end. Wraps an
    <code>unwind-protect</code> that makes sure the back-end is
    destroyed when the body exits.</p>

    <p class="def" id="destroy">
      <span>function</span> destroy ()
    </p>

    <p class="desc">Destroy the current back-end. This will close the
    top-level window, and dispose of any resources that were held.</p>

    <p class="def" id="alive-p">
      <span>function</span> alive-p ()
    </p>

    <p class="desc">Test whether the current back-end is still alive.
    After the user manually closes or kills the top-level window, this
    will return <code>nil</code>.</p>

    <h3 id="evaluation">Tcl evaluation</h3>

    <p>The main thing to do with this library is sending Tcl commands
    to an interpreter, in order to make some windowing interface do
    what you want. The following commands try to make this easy.</p>

    <p class="def" id="tcl">
      <span>function</span> tcl (command &amp;rest args)
    </p>

    <p class="desc">Run a piece of Tcl code in the current back-end.
    The first argument is sent as-is, the rest are converted to
    strings by the rules below, separated by spaces, and appended to
    the first argument.</p>

    <dl class="desc">
      <dt>string</dt><dd>Strings simply <a href="#tcl-escape">escaped</a>.</dd>
      <dt>number</dt><dd>Converted to a string as per <code>princ-to-string</code>.</dd>
      <dt>keyword</dt><dd>Lowercased and prepended by a dash, so that
      named arguments to Tcl operators can look like Lisp keyword
      arguments.</dd>
      <dt>list</dt><dd>Treated as if the elements of the list occurred
      separatly in the argument list.</dd>
      <dt>Tcl literal</dt><dd>These are created with the <a
      href="#lit"><code>lit</code></a> function. They are inserted
      into the command as they are, without any escaping.</dd>
    </dl>

    <p class="desc">So, for example, the following packs the
    <code>.foo.scroll</code> widget into the right side of its
    container.</p>

    <pre class="desc">(tcl "pack" ".foo.scroll" :side "right" :expand 1 :fill "y")</pre>

    <p class="desc">The return value of <code>tcl</code> is the string
    produced by evaluating the given expression. If Tcl signals an
    error, a <a href="#tcl-error"><code>tcl-error</code></a> condition
    is raised.</p>

    <p class="def" id="lit">
      <span>function</span> lit (string)
    </p>

    <p class="desc">Wraps the given string to be inserted literally
    into a Tcl command.</p>

    <p class="def" id="tcl-bracket">
      <span>function</span> tcl[ (command &amp;rest args)
    </p>

    <p class="desc">Like <a href="#tcl"><code>tcl</code></a>, but
    instead of sending the result to the back-end, it is wrapped in
    '[' and ']' and returned as a literal, so that it can be inserted
    into another command. For example...</p>

    <pre class="desc">(tcl "grid" (tcl[ "ttk::frame" ".baz" :padding 10) :column 0 :row 1 :sticky "news")</pre>

    <p class="def" id="tcl-brace">
      <span>function</span> tcl{ (command &amp;rest args)
    </p>

    <p class="desc">Just like <a
    href="#tcl-bracket"><code>tcl[</code></a>, but wraps its result in
    '{' and '}'.</p>

    <p class="def" id="tcl-escape">
      <span>function</span> tcl-escape (string)
    </p>

    <p class="desc">Escape a string so that it can be passed as an
    argument to a Tcl operator. Disables all <code>$</code> and
    <code>[ ]</code> magic by adding backslashes.</p>

    <h3 id="events">Event handling</h3>

    <p>A Tcl application, or at least its interaction with Lisp
    (depending on your back-end) only runs when its event pump is
    running.</p>

    <p class="def" id="doevent">
      <span>function</span> doevent (&amp;optional block)
    </p>

    <p class="desc">Handle one event. When <code>block</code> is true,
    this will wait until an event becomes available, otherwise it will
    return immediately. Returns a boolean indicating whether an event
    was handled (always true in blocking mode).</p>

    <p class="def" id="doevents">
      <span>function</span> doevents ()
    </p>

    <p class="desc">Handle events (without blocking) until no more
    events are available.</p>

    <p class="def" id="mainloop">
      <span>function</span> mainloop ()
    </p>

    <p class="desc">Handle events (blocking) until the current
    back-end is no longer alive.</p>

    <p>CL-TK allows you to associate 'magic' Tcl commands with pieces
    of Lisp code. These commands are then registered as Tcl event
    handlers, and the CL-TK message pump detects when they are fired,
    running your Lisp code.</p>

    <p class="def" id="event-handler">
      <span>function</span> event-handler (function &amp;optional fields)
    </p>

    <p class="desc">Return a string containing a Tcl command
    associated with calling the given function. When
    <code>fields</code> is given (usually you don't need it), it
    should be a list of characters, which will be put into the Tcl
    command as <code>%c</code> markers (see <a
    href="http://www.tcl.tk/man/tcl8.5/TkCmd/bind.htm#M24"><code>bind</code></a>),
    with their substitutions passed as arguments to the function.
    Returns the handler ID (see below) as a second value. For
    example:</p>

    <pre class="desc">(tcl "ttk:button" :text "Exit" :command (event-handler #'destroy))</pre>

    <p class="def" id="event-handler-star">
      <span>macro</span> event-handler* (&amp;body body)
    </p>

    <p class="desc">Wraps the given <code>body</code> in a lambda, and
    passes it to <a
    href="#event-handler"><code>event-handler</code></a>.</p>

    <p class="def" id="bind-event">
      <span>macro</span> bind-event (tag event (&amp;rest fields) &amp;body body)
    </p>

    <p class="desc"><a
    href="http://www.tcl.tk/man/tcl8.5/TkCmd/bind.htm">Binds</a> the
    given event for the given tag to a function containing the macro
    body. If <code>fields</code> is given, it should hold
    <code>(variable #\c)</code> pairs, where the second element is the
    character to put into the Tcl event handler, and the first element
    is the variable to which the substitution of this character will
    be bound in the body. Returns an event ID.</p>

    <pre class="desc">(bind-event "." "&lt;1>" ((x #\x) (y #\y))
  (format t "You clicked at ~a,~a.~%" x y))</pre>

    <p>The tricky thing with associating Lisp code with Tcl strings is
    that the two systems have separate garbage collectors, and as such
    it is unclear how long the Lisp closures should live. In toy
    applications, or applications that don't dynamically register
    events, you can ignore this fact. But usually, you should take
    care to clean up your handlers, or you are leaking memory.</p>

    <p class="def" id="unregister-event">
      <span>function</span> unregister-event (id)
    </p>

    <p class="desc">Release the closure stored in the current back-end
    under the given event ID.</p>

    <p class="def" id="event-snapshot">
      <span>function</span> event-snapshot ()
    </p>

    <p class="desc">Retrieve a 'snapshot' of the current event handler
    set. At a later time, you can use <a
    href="#clear-events"><code>clear-events</code></a> to release all
    event handlers registered after this snapshot was taken.</p>

    <p class="def" id="clear-events">
      <span>function</span> clear-events (snapshot)
    </p>

    <p class="desc">Release all events registered since the given <a
    href="#event-snapshot">snapshot</a>.</p>

    <p class="def" id="with-local-events">
      <span>macro</span> with-local-events (&amp;body body)
    </p>

    <p class="desc">Register an event <a
    href="#event-snapshot">snapshot</a> before running the macro body,
    and <code>unwind-protect</code> the body to release that snapshot
    when it unwinds.</p>

    <h3 id="wnames">Window names</h3>

    <p>Tk requires you to come up with a unique 'window name' (as in
    .main.foo.label20) for every widget you create. This gets pretty
    tiresome, but these functions try to ease the pain a little.</p>

    <p class="def" id="wname-var">
      <span>variable</span> *wname*
    </p>

    <p class="desc">If you decide to use CL-TK's wname facilities,
    you'll use this to store the window name of the widget you're
    currently populating.</p>

    <p class="def" id="with-wname">
      <span>macro</span> with-wname (wname &amp;body body)
    </p>

    <p class="desc">Binds <a href="#wname-var"><code>*wname*</code></a>
    to the given value in <code>body</code>.</p>

    <p class="def" id="wname">
      <span>function</span> wname (name &amp;optional id)
    </p>

    <p class="desc">Create a new window name, based on <a
    href="#wname-var"><code>*wname*</code></a>. If <code>*wname*</code>
    is <code>.foo</code>, <code>(wname "bar")</code> gives you
    <code>.foo.bar</code>, and <code>(wname "bar" 10)</code> gives
    <code>.foo.bar10</code>.</p>

    <p class="def" id="wname-cons">
      <span>function</span> wname-cons (name base)
    </p>

    <p class="desc">Extend a base window name. For example,
    <code>(wname-cons "button" ".frame")</code> yields
    <code>".frame.button"</code>.</p>

    <p class="def" id="wname-car">
      <span>function</span> wname-car (wname)
    </p>

    <p class="desc">Take the inner element of a window name.</p>

    <p class="def" id="wname-cdr">
      <span>function</span> wname-cdr (wname)
    </p>

    <p class="desc">Return the outer element of window name. For
    example <code>(wname-cdr ".dialog.top.scroll")</code> gives
    <code>.dialog.top</code>.</p>

    <h3 id="errors">Errors</h3>

    <p id="tcl-error">All errors raised by CL-TK have the type
    <code>tcl-error</code>, which is a subclass of
    <code>simple-error</code> without extra slots.</p>

  </body>
</html>


<|start_filename|>cl-tk.asd<|end_filename|>
(eval-when (compile eval load)
  (when (ignore-errors (asdf:find-system :cffi))
    (pushnew :cffi *features*)))

(asdf:defsystem :cl-tk
  :description "Minimal bridge to Tcl/Tk"
  :author "<NAME> <<EMAIL>>"
  :license "BSD"
  :depends-on (#+(and (not allegro) cffi) :cffi)
  :components ((:file "package")
               (:file "base" :depends-on ("package"))
               (:file "wish" :depends-on ("base"))
               #+(and (not allegro) cffi) (:file "cffi" :depends-on ("base"))
               #+allegro (:file "acl" :depends-on ("base"))
               #+(or cffi allegro) (:file "ffi" :depends-on (#+(and (not allegro) cffi) "cffi" #+allegro "acl"))))


<|start_filename|>acl.lisp<|end_filename|>
(in-package :cl-tk)

(let ((loaded nil))
  (defun load-libs ()
    (unless loaded
      #+unix
      (progn (load "libtcl8.5.so")
             (load "libtk8.5.so"))
      #+mswindows
      (progn (load "tcl85.dll")
             (load "tk85.dll"))
      #+(and (not mswindows) (not unix))
      (error "Don't know how to load Tk libraries on this system.")
      (setf loaded t))))

(ff:def-foreign-call (create-interp "Tcl_CreateInterp") (:void) :returning (:foreign-address))
(ff:def-foreign-call (delete-interp "Tcl_DeleteInterp") ((interp :foreign-address)) :returning :void)
(ff:def-foreign-call (tcl-init "Tcl_Init") ((interp :foreign-address)) :returning (:int))
(ff:def-foreign-call (tcl-eval% "Tcl_Eval") ((interp :foreign-address) (script :foreign-address)) :returning (:int))
(defun tcl-eval (interp script)
  (excl:with-native-string (script script :external-format :utf-8)
    (tcl-eval% interp script)))
(ff:def-foreign-call (get-string-result% "Tcl_GetStringResult") ((interp :foreign-address)) :returning (:foreign-address))
(defun get-string-result (interp)
  (excl:native-to-string (get-string-result% interp) :external-format :utf-8))
(ff:def-foreign-call (do-one-event "Tcl_DoOneEvent") ((flags :int)) :returning (:int))
(ff:def-foreign-call (tk-init "Tk_Init") ((interp :foreign-address)) :returning (:int))

(defun null-pointer-p (ptr) (zerop ptr))


<|start_filename|>cffi.lisp<|end_filename|>
(in-package :cl-tk)

(cffi:define-foreign-library tcl
  (:darwin (:framework "Tcl"))
  (:windows (:or "tcl85.dll"))
  (:unix (:or "libtcl8.5.so" "libtcl.so"))
  (t (:default "libtcl")))

(cffi:define-foreign-library tk
  (:darwin (:framework "Tk"))
  (:windows (:or "tk85.dll"))
  (:unix (:or "libtk8.5.so" "libtk.so"))
  (t (:default "libtk")))

(let ((loaded nil))
  (defun load-libs ()
    (unless loaded
      (cffi:use-foreign-library tcl)
      (cffi:use-foreign-library tk)
      (setf loaded t))))

(cffi:defcfun ("Tcl_CreateInterp" create-interp) :pointer)
(cffi:defcfun ("Tcl_DeleteInterp" delete-interp) :void (interp :pointer))
(cffi:defcfun ("Tcl_Init" tcl-init) :int (interp :pointer))
(cffi:defcfun ("Tcl_Eval" tcl-eval) :int (interp :pointer) (script (:string :encoding :utf-8)))
(cffi:defcfun ("Tcl_GetStringResult" get-string-result) (:string :encoding :utf-8) (interp :pointer))
(cffi:defcfun ("Tcl_DoOneEvent" do-one-event) :int (flags :int))
(cffi:defcfun ("Tk_Init" tk-init) :int (interp :pointer))

(defun null-pointer-p (ptr) (cffi:null-pointer-p ptr))
