Update of /project/cells/cvsroot/Celtk
In directory cl-net:/tmp/cvs-serv29747
Modified Files:
widget.lisp
Log Message:
Added: ON-HOVER functionality provided by Andy Chambers:
The usage would be...
(defmd my-window (window)
:kids (c? (the-kids
(mk-stack (:packing (c?pack-self))
(mk-label :text "hi"
:on-hover (lambda ()
(trc "hovering...")))))))
The on-hover function only gets called after the mouse has been sitting in the
widget for 1 1/2 seconds.
Thanks again, Andy!
Thanks again, Andy!
--- /project/cells/cvsroot/Celtk/widget.lisp 2008/03/17 20:33:57 1.22
+++ /project/cells/cvsroot/Celtk/widget.lisp 2009/07/12 11:34:49 1.23
@@ -51,6 +51,7 @@
(return-from xwin-widget self))
finally (trc "xwin-widget > no widget for xwin " xwin)))))
+widget-event-handle
;;; --- widget -----------------------------------------
(defmodel widget (family tk-object)
@@ -138,7 +139,7 @@
(bif (self (tkwin-widget client-data))
(widget-event-handle self xe)
;; sometimes I hit the next branch restarting after crash....
- (trc nil "widget-event-handler > no widget for tkwin ~a" client-data))
+ (trc "widget-event-handler > no widget for tkwin" (tkwin-widget client-data)))
#+nahhh(handler-case
(bif (self (tkwin-widget client-data))
(widget-event-handle self xe)
@@ -176,24 +177,43 @@
(export! widget-event-handle)
(defmethod widget-event-handle ((self widget) xe) ;; override for class-specific handling
- (trc nil "bingo widget-event-handle" (xevent-type xe))
+ (trc "bingo >>>>>>> widget-event-handle" (xevent-type xe))
(bif (h (^event-handler)) ;; support instance-specific handlers
(funcall h self xe)
(case (xevent-type xe)
- (:buttonpress (trc "button pressed:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe)))
- (:buttonrelease (trc "button released:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe)))(:MotionNotify
- (xevent-dump xe))
+ (:buttonpress
+ (trc "button pressed:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe)))
+ (:buttonrelease
+ (trc "button released:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe)))
+ (:MotionNotify (xevent-dump xe))
+ (:EnterNotify (initiate-hover-event self))
+ (:LeaveNotify (cancel-hover-event self))
(:virtualevent))))
+(defun initiate-hover-event (self)
+ (setf (hover-timer self)
+ (make-instance 'timer
+ :delay 1500
+ :repeat (c-in 1)
+ :action (lambda (timer)
+ (declare (ignore timer)
+ (bif (fn (on-hover self))
+ (funcall fn)))))))
+
+(defun cancel-hover-event (self)
+ (cancel-timer (hover-timer self)))
+
(defmethod tk-configure ((self widget) option value)
(tk-format `(:configure ,self ,option) "~a configure ~(~a~) ~a" (path self) option (tk-send-value value)))
-
(defmethod not-to-be :after ((self widget))
- (when (or (and (eql self .tkw) (not (find .tkw *windows-destroyed*)))
- (not (find .tkw *windows-being-destroyed*)))
- (trc "not-to-be destroying widget" (^path))
- (break "not to be")
+ (trc nil "NOT-TO-BE :AFTER (self widget): .tkw | self -> " .tkw self)
+ (trc nil "NOT-TO-BE :AFTER (self widget): *windows-destroyed* -> " *windows-destroyed*)
+ (trc nil "NOT-TO-BE :AFTER (self widget): *windows-being-destroyed* -> " *windows-being-destroyed*)
+ (when (or (and (eql self .tkw)
+ (not (find .tkw *windows-destroyed*)))
+ (not (find .tkw *windows-being-destroyed*)))
+ (trc nil "not-to-be destroying widget" (^path))
(tk-format `(:forget ,self) "pack forget ~a" (^path))
(tk-format `(:destroy ,self) "destroy ~a" (^path))))
@@ -310,9 +330,6 @@
(tcl-set-var *tki* (tk-variable self) v$ (var-flags :tcl-namespace-only))))))
-
-
-
;;; --- menus ---------------------------------
(defun pop-up (menu x y)
