[mcclim-cvs] CVS mcclim/Backends/gtkairo
dlichteblau
dlichteblau at common-lisp.net
Sun Nov 12 13:46:09 UTC 2006
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))
More information about the Mcclim-cvs
mailing list