Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17453

Modified Files: gadgets.lisp Log Message:

As an extension, recognize an initarg :PRESENTATION-TYPE-KEY to the list pane. Like :VALUE-KEY and :NAME-KEY, it can specify a function to be called for each list item. The presentation type key can return NIL, or a presentation type to be used for the item.

If such a type is returned, selection of the item will throw a presentation of that type before the value-change callback is called.

In addition, right click will be recognized on the list pane and open a presentation menu.

* gadgets.lisp (META-LIST-PANE): New slot presentation-type-key. ((VALUE-CHANGED-CALLBACK :BEFORE META-LIST-PANE)): Optionally throw a presentation. (AD-HOC-PRESENTATION, OUTPUT-RECORD-HIT-DETECTION-RECTANGLE*): New class and method. (GENERIC-LIST-PANE-HANDLE-RIGHT-CLICK, META-LIST-PANE-CALL-PRESENTATION-MENU): New functions. ((HANDLE-EVENT GENERIC-LIST-PANE)): Handle right clicks. * Examples/demodemo.lisp (list-pane-test): Modified to demonstrate presentation-type-key. * Backends/gtkairo/event.lisp (HANDLE-EVENT-P): New generic function. (BUTTON-HANDLER): Trap the event only if handle-event-p returns true. * Backends/gtkairo/gadgets.lisp ((HANDLE-EVENT-P GTK-LIST), (CONNECT-NATIVE-SIGNALS GTK-LIST)): Handle right clicks. (GTK-LIST-ONE-VALUE): New function. ((HANDLE-EVENT GTK-LIST)): Call meta-list-pane-call-presentation-menu.

--- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/12/23 21:44:03 1.102 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/12/27 14:47:23 1.103 @@ -1917,7 +1917,11 @@ :initform #'identity :reader list-pane-value-key :documentation "A function to be applied to items to gain its value - for the purpose of GADGET-VALUE.") + for the purpose of GADGET-VALUE.") + (presentation-type-key :initarg :presentation-type-key + :initform (constantly nil) + :reader list-pane-presentation-type-key + :documentation "A function to be applied to items to find the presentation types for their values, or NIL.") (test :initarg :test :initform #'eql :reader list-pane-test @@ -1970,6 +1974,16 @@ (> (length (gadget-value gadget)) 1)) (error "An 'exclusive' list-pane cannot be initialized with more than one item selected.")))

+(defmethod value-changed-callback + :before + ((gadget meta-list-pane) client gadget-id value) + (declare (ignore client gadget-id)) + (let* ((i (position value (generic-list-pane-item-values gadget))) + (item (elt (list-pane-items gadget) i)) + (ptype (funcall (list-pane-presentation-type-key gadget) item))) + (when ptype + (throw-object-ptype value ptype)))) + (defun list-pane-exclusive-p (pane) (or (eql (list-pane-mode pane) :exclusive) (eql (list-pane-mode pane) :one-of))) @@ -2163,11 +2177,47 @@ (multiple-value-bind (x y) (values (pointer-event-x event) (pointer-event-y event)) (generic-list-pane-handle-click pane x y (event-modifier-state event))))

+(defclass ad-hoc-presentation (standard-presentation) ()) + +(defmethod output-record-hit-detection-rectangle* + ((presentation ad-hoc-presentation)) + (values most-negative-fixnum most-negative-fixnum + most-positive-fixnum most-positive-fixnum)) + +(defun generic-list-pane-handle-right-click (pane event) + (multiple-value-bind (x y) + (values (pointer-event-x event) (pointer-event-y event)) + (multiple-value-bind (item-value index) + (generic-list-pane-item-from-x-y pane x y) + (let* ((item (elt (list-pane-items pane) index))) + (meta-list-pane-call-presentation-menu pane item))))) + +(defun meta-list-pane-call-presentation-menu (pane item) + (let ((ptype (funcall (list-pane-presentation-type-key pane) item))) + (when ptype + (let ((presentation + (make-instance 'ad-hoc-presentation + :object (funcall (list-pane-value-key pane) item) + :single-box t + :type ptype))) + (call-presentation-menu + presentation + *input-context* + *application-frame* + pane + 42 42 + :for-menu t + :label (format nil "Operation on ~A" ptype)))))) + (defmethod handle-event ((pane generic-list-pane) (event pointer-button-press-event)) - (if (eql (pointer-event-button event) +pointer-left-button+) - (progn (generic-list-pane-handle-click-from-event pane event) - (setf (slot-value pane 'armed) nil)) - (when (next-method-p) (call-next-method)))) + (case (pointer-event-button event) + (#.+pointer-left-button+ + (generic-list-pane-handle-click-from-event pane event) + (setf (slot-value pane 'armed) nil)) + (#.+pointer-right-button+ + (generic-list-pane-handle-right-click pane event)) + (t + (when (next-method-p) (call-next-method)))))

(defmethod handle-event ((pane generic-list-pane) (event pointer-button-release-event)) (if (eql (pointer-event-button event) +pointer-left-button+)