112ac1d3 |
1 | ;; Common Lisp bindings for GTK+ v2.x |
2 | ;; Copyright 2005 Espen S. Johnsen <espen@users.sf.net> |
d9a443c9 |
3 | ;; |
112ac1d3 |
4 | ;; Permission is hereby granted, free of charge, to any person obtaining |
5 | ;; a copy of this software and associated documentation files (the |
6 | ;; "Software"), to deal in the Software without restriction, including |
7 | ;; without limitation the rights to use, copy, modify, merge, publish, |
8 | ;; distribute, sublicense, and/or sell copies of the Software, and to |
9 | ;; permit persons to whom the Software is furnished to do so, subject to |
10 | ;; the following conditions: |
d9a443c9 |
11 | ;; |
112ac1d3 |
12 | ;; The above copyright notice and this permission notice shall be |
13 | ;; included in all copies or substantial portions of the Software. |
d9a443c9 |
14 | ;; |
112ac1d3 |
15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
16 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF |
17 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. |
18 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY |
19 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, |
20 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE |
21 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
d9a443c9 |
22 | |
7ce4015b |
23 | ;; $Id: gtkaction.lisp,v 1.7 2006-02-05 12:54:55 espen Exp $ |
d9a443c9 |
24 | |
25 | |
26 | (in-package "GTK") |
27 | |
28 | ;;; Action |
29 | |
a5522de5 |
30 | (defmethod initialize-instance ((action action) &key callback) |
d9a443c9 |
31 | (call-next-method) |
a5522de5 |
32 | (when callback |
33 | (apply #'signal-connect action 'activate (mklist callback)))) |
d9a443c9 |
34 | |
35 | (defmethod action-accelerator ((action action)) |
36 | (object-data action 'accelerator)) |
37 | |
38 | (defbinding (action-is-sensitive-p "gtk_action_is_sensitive") () boolean |
39 | (action action)) |
40 | |
41 | (defbinding (action-is-visible-p "gtk_action_is_visible") () boolean |
42 | (action action)) |
43 | |
44 | (defbinding action-activate () nil |
45 | (action action)) |
46 | |
47 | |
48 | ;;; Action Group |
49 | |
50 | (defmethod initialize-instance ((action-group action-group) &rest initargs |
51 | &key action actions) |
52 | (declare (ignore action actions)) |
13955a62 |
53 | (prog1 |
54 | (call-next-method) |
a5522de5 |
55 | (initial-add action-group #'action-group-add-action |
13955a62 |
56 | initargs :action :actions))) |
d9a443c9 |
57 | |
58 | (defbinding action-group-get-action () action |
59 | (action-group action-group) |
60 | (name string)) |
61 | |
62 | (defbinding action-group-list-actions () (glist action) |
63 | (action-group action-group)) |
64 | |
65 | (defbinding %action-group-add-action () nil |
66 | (action-group action-group) |
67 | (action action)) |
68 | |
69 | (defbinding %action-group-add-action-with-accel () nil |
70 | (action-group action-group) |
71 | (action action) |
72 | (accelerator (or null string))) |
73 | |
74 | (defun action-group-add-action (action-group action) |
a5522de5 |
75 | (if (slot-boundp action 'accelerator) |
76 | (%action-group-add-action-with-accel action-group action (action-accelerator action)) |
77 | (%action-group-add-action action-group action))) |
d9a443c9 |
78 | |
79 | (defbinding action-group-remove-action () nil |
80 | (action-group action-group) |
81 | (action action)) |
82 | |
83 | |
84 | ;;; Radio Action |
85 | |
a5522de5 |
86 | (defmethod initialize-instance ((action radio-action) &key group) |
d9a443c9 |
87 | (call-next-method) |
7ce4015b |
88 | (setf (slot-value action 'self) (sap-int (foreign-location action))) |
d9a443c9 |
89 | (when group |
a5522de5 |
90 | (add-to-radio-group action group))) |
d9a443c9 |
91 | |
92 | (defbinding %radio-action-get-group () pointer |
93 | (radio-action radio-action)) |
94 | |
95 | (defbinding %radio-action-set-group () nil |
96 | (radio-button radio-button) |
97 | (group pointer)) |
98 | |
a5522de5 |
99 | (defmethod add-to-radio-group ((action1 radio-action) (action2 radio-action)) |
d9a443c9 |
100 | "Add ACTION1 to the group which ACTION2 belongs to." |
101 | (%radio-action-set-group action1 (%radio-action-get-group action2))) |
102 | |
a5522de5 |
103 | (defmethod activate-radio-widget ((action radio-action)) |
104 | (action-activate action)) |
105 | |
106 | (defmethod add-activate-callback ((action radio-action) function &key object after) |
107 | (%add-activate-callback action 'activate function object after)) |
108 | |
d9a443c9 |
109 | (defbinding (radio-action-get-current "gtk_radio_action_get_current_value") |
110 | () radio-action |
a5522de5 |
111 | "Returns the current active radio action in the group the give radio action belongs to." |
d9a443c9 |
112 | (radio-action radio-action)) |
113 | |
114 | (defun radio-action-get-current-value (action) |
8292a3d4 |
115 | (radio-action-value (radio-action-get-current action))) |
d9a443c9 |
116 | |
117 | |
118 | |
119 | ;;; Toggle Action |
120 | |
a5522de5 |
121 | (defmethod initialize-instance ((action toggle-action) &rest initargs &key callback) |
122 | (remf initargs :callback) |
123 | (apply #'call-next-method action initargs) |
124 | (when callback |
125 | (destructuring-bind (function &key object after) (mklist callback) |
126 | (signal-connect action 'activate |
127 | (if object |
128 | #'(lambda (object) |
129 | (funcall function object (toggle-action-active-p action))) |
130 | #'(lambda () |
131 | (funcall function (toggle-action-active-p action)))) |
132 | :object object :after after))) |
133 | (when (toggle-action-active-p action) |
134 | (action-activate action))) |
135 | |
d9a443c9 |
136 | (defbinding toggle-action-toggled () nil |
137 | (toggle-action toggle-action)) |
138 | |
139 | |
d9a443c9 |
140 | ;;; UI Manager |
141 | |
142 | (defmethod initialize-instance ((ui-manager ui-manager) &rest initargs |
143 | &key ui action-group) |
144 | (declare (ignore ui action-group)) |
145 | (call-next-method) |
146 | (mapc #'(lambda (action-group) |
147 | (ui-manager-insert-action-group ui-manager action-group)) |
148 | (get-all initargs :action-group)) |
149 | (mapc #'(lambda (ui) |
150 | (ui-manager-add-ui ui-manager ui)) |
151 | (get-all initargs :ui))) |
152 | |
153 | |
154 | (defbinding ui-manager-insert-action-group |
155 | (ui-manager action-group &optional (pos :end)) nil |
156 | (ui-manager ui-manager) |
157 | (action-group action-group) |
158 | ((case pos |
159 | (:first 0) |
160 | (:end -1) |
161 | (t pos)) int)) |
162 | |
163 | (defbinding ui-manager-remove-action-group () nil |
164 | (ui-manager ui-manager) |
165 | (action-group action-group)) |
166 | |
167 | (defbinding ui-manager-get-widget () widget |
168 | (ui-manager ui-manager) |
169 | (path string)) |
170 | |
171 | (defbinding ui-manager-get-toplevels () (glist widget) |
172 | (ui-manager ui-manager) |
173 | (types ui-manager-item-type)) |
174 | |
175 | (defbinding ui-manager-get-action () action |
176 | (ui-manager ui-manager) |
177 | (path string)) |
178 | |
179 | (defbinding %ui-manager-add-ui-from-string (ui-manager ui) int |
180 | (ui-manager ui-manager) |
181 | (ui string) |
182 | ((length ui) int) |
183 | (gerror pointer :out)) |
184 | |
185 | (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec string)) |
186 | (let ((id (%ui-manager-add-ui-from-string ui-manager ui-spec))) |
187 | (when (zerop id) |
188 | (error "We need to handle GError in som way")) |
189 | id)) |
190 | |
191 | (defbinding %ui-manager-add-ui-from-file () int |
192 | (ui-manager ui-manager) |
193 | (filename pathname) |
194 | (gerror pointer :out)) |
195 | |
196 | (defmethod ui-manager-add-ui ((ui-manager ui-manager) (path pathname)) |
197 | (let ((id (%ui-manager-add-ui-from-file ui-manager path))) |
198 | (when (zerop id) |
199 | (error "We need to handle GError in som way")) |
200 | id)) |
201 | |
202 | (defbinding %ui-manager-new-merge-id () unsigned-int |
203 | (ui-manager ui-manager)) |
204 | |
205 | (defbinding %ui-manager-add-ui () nil |
206 | (ui-manager ui-manager) |
207 | (merge-id unsigned-int) |
208 | (path string) |
209 | (name string) |
210 | (action (or null string)) |
211 | (type ui-manager-item-type) |
212 | (top boolean)) |
213 | |
214 | (defvar *valid-ui-elements* |
215 | '((:ui :menubar :toolbar :popup :accelerator) |
216 | (:menubar :menuitem :separator :placeholder :menu) |
217 | (:menu :menuitem :separator :placehoder :menu) |
218 | (:popup :menuitem :separator :placehoder :menu) |
219 | (:toolbar :toolitem :separator :placehoder) |
220 | (:placeholder :menuitem :toolitem :separator :placeholder :menu) |
221 | (:menuitem) |
222 | (:toolitem) |
223 | (:separator) |
224 | (:accelerator))) |
225 | |
a5522de5 |
226 | (defvar *anonymous-element-counter* 0) |
227 | (internal *anonymous-element-counter*) |
228 | |
d9a443c9 |
229 | (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec list)) |
230 | (let ((id (%ui-manager-new-merge-id ui-manager))) |
231 | (labels |
232 | ((parse-ui-spec (path ui-spec element) |
233 | (loop |
234 | for definition in ui-spec |
235 | do (destructuring-bind (type &optional name &rest rest) |
236 | (mklist definition) |
237 | (cond |
238 | ((not (find type (cdr (assoc element *valid-ui-elements*)))) |
239 | (ui-manager-remove-ui ui-manager id) |
240 | (error "~S not valid subelement in ~S" type element)) |
241 | ((multiple-value-bind (action children) |
242 | (if (and rest (atom (first rest)) |
243 | (not (keywordp (first rest)))) |
244 | (values (first rest) (rest rest)) |
245 | (values name rest)) |
a5522de5 |
246 | (%ui-manager-add-ui ui-manager |
247 | id (or path "/") |
248 | (or name (format nil "~A~D" |
249 | (string-capitalize type) |
250 | (incf *anonymous-element-counter*))) |
251 | action type nil) |
d9a443c9 |
252 | (when children |
253 | (parse-ui-spec (concatenate 'string path "/" name) |
254 | children type))))))))) |
255 | (parse-ui-spec nil ui-spec :ui)) |
256 | id)) |
257 | |
258 | (defbinding ui-manager-remove-ui () nil |
259 | (ui-manager ui-manager) |
260 | (merge-id unsigned-int)) |
261 | |
262 | (defbinding ui-manager-get-ui () string |
263 | (ui-manager ui-manager)) |
264 | |
265 | (defbinding ui-manager-ensure-update () nil |
266 | (ui-manager ui-manager)) |