Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv29396/Backends/gtkairo
Modified Files: event.lisp frame-manager.lisp gadgets.lisp gtk-ffi.lisp Log Message:
"Maybe later"
Implement native context menus by injecting a callback for invocation in the event loop, instead of popping them up in frame-manager-menu-choose, which GTK+ does not like at all.
* gtk-ffi.lisp (g_idle_add): New declaration.
* frame-manager.lisp (FRAME-MANAGER-MENU-CHOOSE): Enable this definition. Call `gtk_menu_popup' through INVOKE-LATER. Recognize context-menu-cancelled-event. Remove unused variables.
* gadgets.lisp (CONTEXT-MENU-CANCELLED-EVENT): New class. (DESTRUCTURE-MC-MENU-ITEM): Assume type :ITEM if the plist doesn't specify otherwise. (MAKE-CONTEXT-MENU): Install a handler for signal `deactivate'. * event.lisp (*LAST-SEEN-BUTTON*): New variable. (BUTTON-HANDLER): Record the last button that got pressed. (POPUP-DEACTIVATED-HANDLER): New callback. (INVOKE-LATER, IDLE-FUNCTION, *LATER-TABLE*, *LATER-COUNTER*): New definitions.
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/12 11:26:13 1.11 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/12 13:46:08 1.12 @@ -246,12 +246,15 @@ :modifier-state (gdkmodifiertype->modifier-state state) :timestamp time))))))))
+(defvar *last-seen-button* 3) + (define-signal button-handler (widget event) (cffi:with-foreign-slots ((type time button state x y x_root y_root) event gdkeventbutton) (when (eql type GDK_BUTTON_PRESS) ;; Hack alert: Menus don't work without this. (gdk_pointer_ungrab GDK_CURRENT_TIME)) + (setf *last-seen-button* button) (enqueue (make-instance (if (eql type GDK_BUTTON_PRESS) 'pointer-button-press-event @@ -368,6 +371,12 @@ :value (dummy-menu-item-sheet-value dummy-item) :itemspec (dummy-menu-item-sheet-itemspec dummy-item)))))
+(define-signal popup-deactivated-handler (widget (menu :pointer)) + menu + (enqueue + (make-instance 'context-menu-cancelled-event + :sheet (widget->sheet widget *port*)))) + #-sbcl (define-signal (scrollbar-change-value-handler :return-type :int) (widget (scroll gtkscrolltype) (value :double)) @@ -386,3 +395,19 @@ :value (sb-kernel:make-double-float hi lo) :sheet (widget->sheet widget *port*))) 1) + +(defvar *later-table* (make-hash-table)) +(defvar *later-counter* 0) + +(defun invoke-later (fun) + (with-gtk () + (let ((i (incf *later-counter*))) + (setf (gethash i *later-table*) fun) + (g_idle_add (cffi:get-callback 'idle-function) i)))) + +(cffi:defcallback idle-function :int + ((data :long)) ;hack + (let ((fun (gethash data *later-table*))) + (remhash data *later-table*) + (funcall fun)) + 0) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/05/13 19:37:29 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/12 13:46:08 1.5 @@ -116,15 +116,14 @@ (port-enable-sheet (car climi::*all-ports*) (slot-value frame 'climi::top-level-sheet)))
-#+(or) ;doesn't work yet (defmethod frame-manager-menu-choose ((frame-manager gtkairo-frame-manager) items &key associated-window printer presentation-type - (default-item nil default-item-p) - text-style label cache unique-id id-test cache-value cache-test - max-width max-height n-rows n-columns x-spacing y-spacing row-wise - cell-align-x cell-align-y scroll-bars pointer-documentation) + (default-item nil default-item-p) + text-style label cache unique-id id-test cache-value cache-test + max-width max-height n-rows n-columns x-spacing y-spacing row-wise + cell-align-x cell-align-y scroll-bars pointer-documentation) (declare ;; XXX hallo? (ignore printer presentation-type default-item default-item-p @@ -136,16 +135,27 @@ (pane-frame associated-window) *application-frame*)) (port (port frame)) - (tls (slot-value frame 'climi::top-level-sheet)) - (tls-mirror (climi::port-lookup-mirror port tls)) (sheet (make-instance 'dummy-context-menu-sheet)) (menu (make-context-menu port sheet items))) - (gtk_menu_popup menu - (cffi:null-pointer) - (cffi:null-pointer) - (cffi:null-pointer) - (cffi:null-pointer) - 0 - (gtk_get_current_event_time)) + (invoke-later + (lambda () + (invoke-later (lambda () (gdk_pointer_ungrab GDK_CURRENT_TIME))) + (gtk_menu_popup menu + (cffi:null-pointer) + (cffi:null-pointer) + (cffi:null-pointer) + (cffi:null-pointer) + *last-seen-button* + (gtk_get_current_event_time)))) (let ((event (event-read sheet))) - (values (event-value event) (event-itemspec event) event)))) + ;; `deactivate' is signalled on the menu before `clicked' on the item, + ;; so let's make sure we have processed all events before deciding + ;; whether the was a `clicked' or not + (gtk-main-iteration port) + (when (typep (event-peek sheet) 'context-menu-clicked-event) + (setf event (event-read sheet))) + (etypecase event + (context-menu-clicked-event + (values (event-value event) (event-itemspec event) event)) + (context-menu-cancelled-event + nil))))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/06/10 10:08:49 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/12 13:46:08 1.7 @@ -33,6 +33,8 @@ ((value :initarg :value :accessor event-value) (itemspec :initarg :itemspec :accessor event-itemspec)))
+(defclass context-menu-cancelled-event (gadget-event) ()) +
;;;; Classes
@@ -163,7 +165,7 @@ (&key value style items documentation active type) (cdr x) (declare (ignore style documentation active)) - (values (if items :menu type) + (values (cond (items :menu) (type) (t :item)) (car x) (or value (car x)) items))))) @@ -208,6 +210,8 @@ (gtk_menu_item_set_submenu item menu) item))))) (gtk_menu_shell_append menu gtkmenuitem)))) + (setf (widget->sheet menu port) sheet) + (connect-signal menu "deactivate" 'popup-deactivated-handler) (gtk_widget_show_all menu) menu))
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/12 11:26:13 1.12 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/12 13:46:08 1.13 @@ -776,6 +776,13 @@ (rect :pointer) (childrenp :int))
+(defcfun "g_idle_add" + :int + (fun :pointer) + ;; hack + ;; (data :pointer) + (data :long)) + (defconstant GDK_EXPOSURE_MASK (ash 1 1)) (defconstant GDK_POINTER_MOTION_MASK (ash 1 2)) (defconstant GDK_POINTER_MOTION_HINT_MASK (ash 1 3))