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

Diff of /mcclim/menu.lisp

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

revision 1.38 by ahefner, Sat Dec 23 11:52:27 2006 UTC revision 1.39 by thenriksen, Tue Jan 29 19:13:07 2008 UTC
# Line 125  Line 125 
125    ()    ()
126    (:default-initargs :border-width 2 :background *3d-normal-color*))    (:default-initargs :border-width 2 :background *3d-normal-color*))
127    
128    (defun make-menu-buttons (command-table-name client)
129      "Map over the available menu items in the command table with
130    name `command-table-name', taking inherited menu items into
131    account, and create a list of menu buttons."
132      (let ((menu-buttons '()))
133        (map-over-command-table-menu-items
134         #'(lambda (name gesture item)
135             (declare (ignore name gesture))
136             (push (make-menu-button-from-menu-item
137                    item client :command-table command-table-name :vertical t)
138                   menu-buttons))
139         command-table-name)
140        (nreverse menu-buttons)))
141    
142  (defun create-substructure (sub-menu client)  (defun create-substructure (sub-menu client)
143    (let* ((frame *application-frame*)    (let* ((frame *application-frame*)
144           (manager (frame-manager frame))           (manager (frame-manager frame))
145           (command-table-name (slot-value sub-menu 'command-table))           (command-table-name (slot-value sub-menu 'command-table))
146           (items (mapcar #'(lambda (item)           (items (make-menu-buttons command-table-name client))
                             (make-menu-button-from-menu-item  
                              item client :command-table command-table-name :vertical t))  
                         (slot-value (find-command-table command-table-name)  
                                     'menu)))  
147           (rack (make-pane-1 manager frame 'vrack-pane           (rack (make-pane-1 manager frame 'vrack-pane
148                              :background *3d-normal-color* :contents items))                              :background *3d-normal-color* :contents items))
149           (raised (make-pane-1 manager frame 'submenu-border :contents (list rack))))           (raised (make-pane-1 manager frame 'submenu-border :contents (list rack))))

Legend:
Removed from v.1.38  
changed lines
  Added in v.1.39

  ViewVC Help
Powered by ViewVC 1.1.5