/[mcclim]/mcclim/menu.lisp
ViewVC logotype

Diff of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.27 by gilbert, Mon Apr 21 23:51:29 2003 UTC revision 1.28 by moore, Fri Jul 11 13:47:52 2003 UTC
# Line 20  Line 20 
20    
21  (in-package :clim-internals)  (in-package :clim-internals)
22    
23    (defmethod stream-force-output ((pane menu-button-pane))
24      (with-sheet-medium (medium pane)
25        (medium-force-output medium)))
26    
27  (defmethod menu-root ((button menu-button-pane))  (defmethod menu-root ((button menu-button-pane))
28    (menu-root (gadget-client button)))    (menu-root (gadget-client button)))
29    
# Line 35  Line 39 
39    (with-slots (client armed id) button    (with-slots (client armed id) button
40      (when armed      (when armed
41        (disarm-gadget button)        (disarm-gadget button)
42        (dispatch-repaint button (sheet-region button)))))        (dispatch-repaint button (sheet-region button))
43          (stream-force-output button))))
44    
45  (defun menu-draw-highlighted (gadget)  (defun menu-draw-highlighted (gadget)
46    (when (sheet-mirror gadget)           ;XXX only do this when the gadget is realized.    (when (sheet-mirror gadget)           ;XXX only do this when the gadget is realized.
# Line 89  Line 94 
94  (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event))  (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event))
95    (with-slots (armed label client id) pane    (with-slots (armed label client id) pane
96      (when armed      (when armed
97        (value-changed-callback pane client id label)        (unwind-protect
98        (disarm-menu pane)             (value-changed-callback pane client id label)
99        (destroy-substructure (menu-root pane)))))          (disarm-menu pane)
100            (destroy-substructure (menu-root pane))))))
101    
102  (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event))  (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event))
103    (disarm-menu pane))    (disarm-menu pane))
# Line 135  Line 141 
141            (with-slots (frame-manager submenu-frame) sub-menu            (with-slots (frame-manager submenu-frame) sub-menu
142              (setf frame-manager manager              (setf frame-manager manager
143                    submenu-frame (make-menu-frame raised :left x :top y))                    submenu-frame (make-menu-frame raised :left x :top y))
144              (adopt-frame manager submenu-frame)))))))              (adopt-frame manager submenu-frame)
145                (with-sheet-medium (medium raised)
146                  (medium-force-output medium))))))))
147    
148  (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))  (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
149    (with-slots (frame-manager submenu-frame) sub-menu    (with-slots (frame-manager submenu-frame) sub-menu
# Line 165  Line 173 
173  ;; for now, accept only types :command and :menu, and only  ;; for now, accept only types :command and :menu, and only
174  ;; command names as values of :command  ;; command names as values of :command
175  (defun make-menu-button-from-menu-item (item client  (defun make-menu-button-from-menu-item (item client
176                                          &key (bottomp nil) command-table)                                          &key (bottomp nil)
177                                            command-table
178                                            (presentation-type 'menu-item))
179      (declare (ignore command-table))
180    (let ((name (command-menu-item-name item))    (let ((name (command-menu-item-name item))
181          (type (command-menu-item-type item))          (type (command-menu-item-type item))
182          (value (command-menu-item-value item))          (value (command-menu-item-value item))
183          (frame *application-frame*)          (frame *application-frame*)
184          (manager (frame-manager *application-frame*)))          (manager (frame-manager *application-frame*)))
185      (if (eq type :command)      (if (eq type :command)
186          (let ((value (if (consp value)          (make-pane-1 manager frame 'menu-button-leaf-pane
187                           value                       :label name
188                           (list value)))                       :client client
189                (ptype (if command-table                       :value-changed-callback
190                           `(command :command-table ,command-table)                       #'(lambda (gadget val)
191                           '(command))))                           (declare (ignore gadget val))
192            (make-pane-1 manager frame 'menu-button-leaf-pane                           (throw-object-ptype item presentation-type)))
                        :label name  
                        :client client  
                        :value-changed-callback  
                        #'(lambda (gadget val)  
                            (declare (ignore gadget val))  
                            (throw-object-ptype value ptype))))  
193          (make-pane-1 manager frame 'menu-button-submenu-pane          (make-pane-1 manager frame 'menu-button-submenu-pane
194                       :label name                       :label name
195                       :client client                       :client client

Legend:
Removed from v.1.27  
changed lines
  Added in v.1.28

  ViewVC Help
Powered by ViewVC 1.1.5