[cells-cvs] CVS Celtk

[fgoenninger]

Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv4140

Modified Files:
	entry.lisp 
Log Message:
changed: entry widget: in order to detect events reliably the
         event id is interned as a keyword.

--- /project/cells/cvsroot/Celtk/entry.lisp	2007/01/29 06:48:41	1.18
+++ /project/cells/cvsroot/Celtk/entry.lisp	2008/03/23 11:36:42	1.19
@@ -16,7 +16,7 @@
 
 |#
 
-;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.18 2007/01/29 06:48:41 ktilton Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.19 2008/03/23 11:36:42 fgoenninger Exp $
 
 (in-package :Celtk)
 
@@ -40,21 +40,25 @@
     :xscrollcommand (c-in nil)
     :textvariable (c? (intern (^path)))
     :event-handler (lambda (self xe)
-                     (TRC nil "ENTRY event-handler" self (xsv type xe) (tk-event-type (xsv type xe)))
+                     (trc nil "ENTRY event-handler" self (xsv type xe) (tk-event-type (xsv type xe)))
                      (case (tk-event-type (xsv type xe))
                        (:virtualevent
-                        (trc nil "ENTRY virtual event" (xsv name xe))
-                        (case (read-from-string (string-upcase (xsv name xe)))
-                          (trace
-                           (TRC nil "entry e/h trace" self (when (plusp (xsv user-data xe))
-                                                              (tcl-get-string (xsv user-data xe))))
-                           ;; assuming write op, but data field shows that
-                           (let ((new-value (tcl-get-var *tki* (^path)
-                                              (var-flags :TCL-NAMESPACE-ONLY))))
-                             (unless (string= new-value (^value))
-                               (setf (^value) new-value))))))))
-   
-    :value (c-in "")))
+                        (trc "ENTRY virtual event" (xsv name xe))
+                        (let ((event-id (intern
+                                          (read-from-string
+                                           (string-upcase (xsv name xe)))
+                                          :keyword)))
+                          (case event-id
+                            (:trace
+                              (TRC  "entry e/h trace" self
+                                   (when (plusp (xsv user-data xe))
+                                     (tcl-get-string (xsv user-data xe))))
+                              ;; assuming write op, but data field shows that
+                              (let ((new-value (tcl-get-var *tki* (^path)
+                                                            (var-flags :TCL-NAMESPACE-ONLY))))
+                                (unless (string= new-value (^value))
+                                  (setf (^value) new-value)))))))))
+   :value (c-in "")))
 
 (defmethod md-awaken :after ((self entry)) ;; move this to a traces slot on widget
   (with-integrity (:client `(:trace ,self))
@@ -64,10 +68,12 @@
 ;;; those leverage the COMMAND mechanism, which entry lacks
 ;;
 (defobserver .value ((self entry))
+  (trc nil "ENTRY self new-value old-value" self new-value old-value)
   (when new-value 
     (unless (string= new-value old-value)
-      (trc nil "value output" self new-value)
-      (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY)))))
+      (trc "ENTRY value output self new-value old-value" self new-value old-value) ;; frgo, 2007-11-22
+      (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY))
+      #+frgo (tk-format-now "~a -text ~A" (^path) new-value))))
 
 (deftk text-widget (widget)
   ((modified :initarg :modified :accessor modified :initform nil))
@@ -97,7 +103,7 @@
                        (:virtualevent
                         (case (read-from-string (string-upcase (xsv name xe)))
                           (modified
-                           (eko (nil "<<Modified>> !!TK value for text-widget" self)
+                           (eko (nil "<<Modified>> !!TK value for text-widget" self) ;; frgo, 2007-11-22
                              (setf (^modified) t)))))
                        ))))