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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (hide annotations)
Sat Apr 27 11:04:30 2002 UTC (11 years, 11 months ago) by gilbert
Branch: MAIN
Changes since 1.13: +25 -52 lines
Bug fix: Do not draw to a non-realized gadget, but marked with three
X's, since not strictly correct.

Attempts to fix <3cca70f63d04b1f3@mel-rta1.wanadoo.fr>:

| From: Pixel / Edena <pixel@pixeledena.com>
| To: free-clim@mikemac.com
| Subject: Something is broken
| Date: Sat, 27 Apr 2002 11:37:05 +0200
|
| Hi,
|
| I've just compiled the last CVS updates and here is what I get once
| I click on a menu item (inside a menubar, even with clim-fig or with my own
| code) :
|
| Type-error in KERNEL::OBJECT-NOT-TYPE-ERROR-HANDLER:
|    NIL is not of type XLIB:DRAWABLE
|
| Restarts:
|   0: [ABORT] Return to Top-Level.
|
| Debug  (type H for help)
|
| (XLIB:DRAW-RECTANGLE 7 NIL #<XLIB:GCONTEXT :0 12583010> 0 ...)[:EXTERNAL]
| 0]
|
| I know this error occurs only when (run-frame-top-level) is launched.
|
| Any idea ?
|
| J.Pouderoux
1 cvs 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 2000 by
4     ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
5    
6     ;;; This library is free software; you can redistribute it and/or
7     ;;; modify it under the terms of the GNU Library General Public
8     ;;; License as published by the Free Software Foundation; either
9     ;;; version 2 of the License, or (at your option) any later version.
10     ;;;
11     ;;; This library is distributed in the hope that it will be useful,
12     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14     ;;; Library General Public License for more details.
15     ;;;
16     ;;; You should have received a copy of the GNU Library General Public
17     ;;; License along with this library; if not, write to the
18     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19     ;;; Boston, MA 02111-1307 USA.
20    
21     (in-package :CLIM-INTERNALS)
22    
23     (defmethod menu-root ((button menu-button-pane))
24     (menu-root (gadget-client button)))
25    
26     (defmethod arm-menu ((button menu-button-pane))
27     (with-slots (client armed id) button
28     (unless armed
29     (arm-menu client)
30     (mapc #'disarm-menu (menu-children client))
31     (setf armed t)
32     (armed-callback button client id))
33     (dispatch-repaint button (sheet-region button))))
34    
35     (defmethod disarm-menu ((button menu-button-pane))
36     (with-slots (client armed id) button
37     (when armed
38     (setf armed nil)
39     (disarmed-callback button client id)
40     (dispatch-repaint button (sheet-region button)))))
41    
42 boninfan 1.9 (defun menu-draw-highlighted (gadget)
43 gilbert 1.14 (when (sheet-mirror gadget) ;XXX only do this when the gadget is realized.
44     (with-special-choices (gadget)
45     (with-slots (label) gadget
46     (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
47     (let ((w (- x2 x1))
48     (h (- y2 y1)))
49     (draw-rectangle* gadget -1 -1 x2 y2
50     :ink (gadget-highlighted-color gadget)
51     :filled t)
52     (draw-edges-lines* gadget 0 0 (1- w) (1- h)) ;(- w 2) (- h 2)
53     (draw-text* gadget label (round w 2) (round h 2)
54     :align-x :center :align-y :center)))))))
55 boninfan 1.9
56 cvs 1.1 (defun menu-draw-unhighlighted (gadget)
57 gilbert 1.14 (when (sheet-mirror gadget) ;XXX only do this when the gadget is realized.
58     (with-special-choices (gadget)
59     (with-slots (label) gadget
60     (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
61     (let ((w (- x2 x1))
62     (h (- y2 y1)))
63     (draw-rectangle* gadget -1 -1 w h ;-1 -1 x2 y2
64     :ink (gadget-normal-color gadget)
65     :filled t)
66     (draw-text* gadget label (round w 2) (round h 2)
67     :align-x :center :align-y :center)))))))
68 cvs 1.1
69     (defmethod handle-event ((pane menu-button-pane) (event pointer-enter-event))
70     (when (slot-value (slot-value pane 'client) 'armed)
71     (arm-branch pane)))
72    
73     (defmethod handle-event ((pane menu-button-pane) (event pointer-button-press-event))
74     (arm-branch pane))
75    
76     (defmethod handle-event ((pane menu-button-pane) (event pointer-ungrab-event))
77     (destroy-substructure (menu-root pane)))
78    
79     ;;; menu-button-leaf-pane
80    
81     (defclass menu-button-leaf-pane (menu-button-pane)
82     ((command :initform nil :initarg :command)))
83    
84     (defmethod arm-branch ((button menu-button-leaf-pane))
85 cvs 1.4 (with-slots (client) button
86     (arm-menu client)
87     (mapc #'destroy-substructure (menu-children client))
88     (arm-menu button)))
89 cvs 1.1
90     (defmethod destroy-substructure ((button menu-button-leaf-pane))
91 cvs 1.4 (with-slots (armed) button
92 cvs 1.1 (setf armed nil)))
93    
94     (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event))
95     (with-slots (armed label client id) pane
96     (when armed
97     (value-changed-callback pane client id label)
98     (disarm-menu pane)
99     (destroy-substructure (menu-root pane)))))
100    
101     (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event))
102 cvs 1.4 (disarm-menu pane))
103 cvs 1.1
104 cvs 1.3 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-ungrab-event))
105     (destroy-substructure (menu-root pane)))
106    
107 gilbert 1.14 (defmethod handle-repaint ((pane menu-button-leaf-pane) region)
108 cvs 1.1 (declare (ignore region))
109     (with-slots (armed) pane
110     (if armed
111     (menu-draw-highlighted pane)
112     (menu-draw-unhighlighted pane))))
113    
114     ;;; menu-button-submenu-pane
115    
116     (defclass menu-button-submenu-pane (menu-button-pane)
117     ((frame-manager :initform nil :initarg :frame-manager)
118     (submenu-frame :initform nil)
119     (bottomp :initform nil :initarg :bottomp)
120     (command-table :initform nil :initarg :command-table)))
121    
122     (defmethod menu-children ((submenu menu-button-submenu-pane))
123     (with-slots (submenu-frame) submenu
124     (if submenu-frame
125 cvs 1.5 (sheet-children (first (sheet-children (frame-pane submenu-frame))))
126 cvs 1.1 '())))
127    
128     (defun create-substructure (sub-menu client)
129     (let* ((frame *application-frame*)
130     (manager (frame-manager frame))
131     (items (mapcar #'(lambda (item)
132     (make-menu-button-from-menu-item item client))
133     (slot-value (find-command-table (slot-value sub-menu 'command-table)) 'menu)))
134 hatchond 1.6 (rack (make-pane-1 manager frame 'vrack-pane
135     :background +grey80+ :contents items))
136 brian 1.13 ;(raised (make-pane-1 manager frame 'raised-pane :contents (list rack)))
137     (raised (make-pane-1 manager frame 'raised-pane :border-width 2 :background +gray80+ :contents (list rack))))
138 cvs 1.1 (with-slots (bottomp) sub-menu
139     (multiple-value-bind (xmin ymin xmax ymax)
140     (bounding-rectangle* (sheet-region sub-menu))
141     (multiple-value-bind (x y)
142     (transform-position (sheet-delta-transformation sub-menu nil)
143     (if bottomp xmin xmax)
144     (if bottomp ymax ymin))
145     (with-slots (frame-manager submenu-frame) sub-menu
146     (setf frame-manager manager
147 cvs 1.5 submenu-frame (make-menu-frame raised :left x :top y))
148 cvs 1.1 (adopt-frame manager submenu-frame)))))))
149    
150     (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
151     (with-slots (frame-manager submenu-frame) sub-menu
152     (when submenu-frame
153     (mapc #'destroy-substructure (menu-children sub-menu))
154     (disown-frame frame-manager submenu-frame)
155     (setf submenu-frame nil))))
156    
157     (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
158 cvs 1.4 (with-slots (client frame-manager submenu-frame) sub-menu
159     (arm-menu client)
160     (if submenu-frame
161     (progn (mapc #'destroy-substructure (menu-children sub-menu))
162     (mapc #'disarm-menu (menu-children sub-menu)))
163     (progn
164     (mapc #'destroy-substructure (menu-children client))
165     (create-substructure sub-menu sub-menu)))
166     (arm-menu sub-menu)))
167 cvs 1.1
168     (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
169     (destroy-substructure (menu-root pane)))
170    
171 gilbert 1.14 (defmethod handle-repaint ((pane menu-button-submenu-pane) region)
172 cvs 1.1 (declare (ignore region))
173     (with-slots (submenu-frame) pane
174     (if submenu-frame
175     (menu-draw-highlighted pane)
176     (menu-draw-unhighlighted pane))))
177    
178     ;; Menu creation from command tables
179    
180     ;; for now, accept only types :command and :menu, and only
181     ;; command names as values of :command
182     (defun make-menu-button-from-menu-item (item client &key (bottomp nil))
183     (let ((name (command-menu-item-name item))
184     (type (command-menu-item-type item))
185     (value (command-menu-item-value item))
186     (frame *application-frame*)
187     (manager (frame-manager *application-frame*)))
188     (if (eq type :command)
189     (make-pane-1 manager frame 'menu-button-leaf-pane
190     :label name
191     :client client
192     :value-changed-callback
193     #'(lambda (gadget val)
194     (declare (ignore gadget val))
195     (funcall value)))
196     (make-pane-1 manager frame 'menu-button-submenu-pane
197     :label name
198     :client client
199     :frame-manager manager
200     :command-table value
201     :bottomp bottomp))))
202    
203     ;;
204     ;; MENU-BAR
205     ;;
206 brian 1.13 (defclass menu-button-hrack-pane (hrack-pane) ())
207 cvs 1.1
208 brian 1.13 (defclass menu-bar (menu-button-hrack-pane
209 gilbert 1.10 permanent-medium-sheet-output-mixin)
210 cvs 1.1 ((items :initform nil)
211     (armed :initform nil)))
212    
213     (defmethod initialize-instance :after ((pane menu-bar)
214     &rest args
215 cvs 1.2 &key
216 cvs 1.1 &allow-other-keys)
217     (declare (ignore args))
218     (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
219     (loop for child in (sheet-children pane)
220     do (setf (gadget-client child) pane)))
221    
222     (defmethod menu-children ((menu-bar menu-bar))
223     (slot-value menu-bar 'items))
224    
225     (defmethod menu-root ((object menu-bar))
226     object)
227    
228     (defmethod destroy-substructure ((object menu-bar))
229 cvs 1.5 (loop for child in (menu-children object)
230 cvs 1.1 do (progn (destroy-substructure child)
231     (dispatch-repaint child (sheet-region child))))
232     (setf (slot-value object 'armed) nil))
233    
234     (defmethod arm-menu ((object menu-bar))
235     (setf (slot-value object 'armed) t))
236    
237     (defmethod disarm-menu ((object menu-bar))
238     (setf (slot-value object 'armed) nil))
239    
240 hatchond 1.6 (defun make-menu-bar (command-table
241     &key width height
242     max-width max-height
243     min-width min-height)
244 cvs 1.1 (with-slots (menu) (find-command-table command-table)
245 gilbert 1.11 (progn ;;raising () ;; XXX temporary medicine as RAISED is borken --GB
246 brian 1.13 (make-pane-1 *pane-realizer* *application-frame*
247 hatchond 1.6 'menu-bar
248     :background +grey80+
249     :width width :height height
250     :max-width max-width :max-height max-height
251     :min-width min-width :min-height min-height
252     :contents
253     (loop for item in menu
254     collect
255     (make-menu-button-from-menu-item item nil :bottomp t))))))

  ViewVC Help
Powered by ViewVC 1.1.5