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))))) ))))