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)