[ltk-user] Convert path strings to CLOS widgets

[David Holz]

I noticed there didn't seem to be any mapping from path strings to CLOS 
widgets in Lisp, useful for things like "winfo children ...".  So here's 
some code that works, diffed from v0.90.  I wrote it, and give permission to 
use in ltk however you want, whatever license, etc legal hoopdedoo.

$ diff -ur ltk.lisp ltk-0.90/ltk.lisp
--- ltk.lisp    2006-07-15 07:45:14.000000000 -0700
+++ ltk-0.90/ltk.lisp   2006-12-26 11:55:43.492704000 -0700
@@ -462,6 +462,12 @@

(defvar *init-wish-hook* nil)

+(defvar *paths-to-widgets* (make-hash-table :test #'equal)
+  "Maps Tcl window path strings to their Lisp widget object.")
+
+(defun path-to-widget (path)
+  (gethash path *paths-to-widgets*))
+
(defun dbg (fmt &rest args)
   (when *debug-tk*
     (apply #'format t fmt args)
@@ -507,6 +513,10 @@
(defun start-wish (&rest keys &key handle-errors handle-warnings (debugger 
t)
                    stream)
   (declare (ignore handle-errors handle-warnings debugger))
+
+  ;; Clear out the name mapping
+  (clrhash *paths-to-widgets*)
+
   ;; open subprocess
   (if (null (wish-stream *wish*))
       (progn
@@ -1166,7 +1176,8 @@
   (send-wish (format nil "bell")))

(defun destroy (widget)
-  (send-wish (format nil "destroy ~a" (widget-path widget))))
+  (send-wish (format nil "destroy ~a" (widget-path widget)))
+  (remhash (widget-path widget) *paths-to-widgets*))

(defun clipboard-clear ()
   (send-wish "clipboard clear"))
@@ -1225,7 +1236,9 @@
(defmethod create ((widget widget))
   (when (init-command widget)
     ;;(format t "creating: ~a~%" (init-command widget)) (finish-output)
-    (format-wish (init-command widget) (widget-path widget))))
+    (format-wish (init-command widget) (widget-path widget))
+    ;; Register this path
+    (setf (gethash (widget-path widget) *paths-to-widgets*) widget)))

(defgeneric (setf command) (value widget))
(defgeneric command (widget))
@@ -2561,6 +2574,12 @@
   (format-wish "senddata [winfo rooty ~a];flush stdout" (widget-path tl))
   (read-data))

+(defun children (w)
+  "give a list of the children of the widget"
+  (format-wish "senddatastrings [winfo children ~a];flush stdout" 
(widget-path w))
+  ;; Convert paths into widget objects
+  (mapcar #'path-to-widget (read-data)))
+
;;; misc functions

(defun focus (widget)

_________________________________________________________________
Dave vs. Carl: The Insignificant Championship Series.  Who will win? 
http://clk.atdmt.com/MSN/go/msnnkwsp0070000001msn/direct/01/?href=http://davevscarl.spaces.live.com/?icid=T001MSN38C07001