chiark / gitweb /
Initial checkin
[clg] / gtk / gtkaction.lisp
CommitLineData
d9a443c9 1;; Common Lisp bindings for GTK+ v2.0
2;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
3;;
4;; This library is free software; you can redistribute it and/or
5;; modify it under the terms of the GNU Lesser General Public
6;; License as published by the Free Software Foundation; either
7;; version 2 of the License, or (at your option) any later version.
8;;
9;; This library is distributed in the hope that it will be useful,
10;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12;; Lesser General Public License for more details.
13;;
14;; You should have received a copy of the GNU Lesser General Public
15;; License along with this library; if not, write to the Free Software
16;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17
18;; $Id: gtkaction.lisp,v 1.1 2004-12-04 18:03:21 espen Exp $
19
20
21(in-package "GTK")
22
23;;; Action
24
25(defmethod initialize-instance ((action action) &key accelerator)
26 (call-next-method)
27 (setf (object-data action 'accelerator) accelerator))
28
29(defmethod action-accelerator ((action action))
30 (object-data action 'accelerator))
31
32(defbinding (action-is-sensitive-p "gtk_action_is_sensitive") () boolean
33 (action action))
34
35(defbinding (action-is-visible-p "gtk_action_is_visible") () boolean
36 (action action))
37
38(defbinding action-activate () nil
39 (action action))
40
41
42;;; Action Group
43
44(defmethod initialize-instance ((action-group action-group) &rest initargs
45 &key action actions)
46 (declare (ignore action actions))
47 (call-next-method)
48 (flet ((add-action (action)
49 (action-group-add-action action-group action)))
50 (loop
51 as (initarg value . rest) = initargs then rest
52 do (case initarg
53 (:action (add-action value))
54 (:actions (mapc #'add-action value)))
55 while rest)))
56
57(defbinding action-group-get-action () action
58 (action-group action-group)
59 (name string))
60
61(defbinding action-group-list-actions () (glist action)
62 (action-group action-group))
63
64(defbinding %action-group-add-action () nil
65 (action-group action-group)
66 (action action))
67
68(defbinding %action-group-add-action-with-accel () nil
69 (action-group action-group)
70 (action action)
71 (accelerator (or null string)))
72
73(defun action-group-add-action (action-group action)
74 (multiple-value-bind (accelerator accelerator-p)
75 (object-data action 'accelerator)
76 (if accelerator-p
77 (%action-group-add-action-with-accel action-group action accelerator)
78 (%action-group-add-action action-group action))))
79
80(defbinding action-group-remove-action () nil
81 (action-group action-group)
82 (action action))
83
84
85;;; Radio Action
86
87(defmethod initialize-instance ((action radio-action) &key group value)
88 (call-next-method)
89 (setf (slot-value action '%value) (system:sap-int (proxy-location action)))
90 (setf (object-data action 'radio-action-value) value)
91 (when group
92 (radio-action-add-to-group action group)))
93
94(defmethod radio-value-action ((action radio-action))
95 (object-data action 'radio-action-value))
96
97(defbinding %radio-action-get-group () pointer
98 (radio-action radio-action))
99
100(defbinding %radio-action-set-group () nil
101 (radio-button radio-button)
102 (group pointer))
103
104(defun radio-action-add-to-group (action1 action2)
105 "Add ACTION1 to the group which ACTION2 belongs to."
106 (%radio-action-set-group action1 (%radio-action-get-group action2)))
107
108(defbinding (radio-action-get-current "gtk_radio_action_get_current_value")
109 () radio-action
110 (radio-action radio-action))
111
112(defun radio-action-get-current-value (action)
113 (radio-value-action (radio-action-get-current action)))
114
115
116
117;;; Toggle Action
118
119(defbinding toggle-action-toggled () nil
120 (toggle-action toggle-action))
121
122
123
124;;; UI Manager
125
126(defmethod initialize-instance ((ui-manager ui-manager) &rest initargs
127 &key ui action-group)
128 (declare (ignore ui action-group))
129 (call-next-method)
130 (mapc #'(lambda (action-group)
131 (ui-manager-insert-action-group ui-manager action-group))
132 (get-all initargs :action-group))
133 (mapc #'(lambda (ui)
134 (ui-manager-add-ui ui-manager ui))
135 (get-all initargs :ui)))
136
137
138(defbinding ui-manager-insert-action-group
139 (ui-manager action-group &optional (pos :end)) nil
140 (ui-manager ui-manager)
141 (action-group action-group)
142 ((case pos
143 (:first 0)
144 (:end -1)
145 (t pos)) int))
146
147(defbinding ui-manager-remove-action-group () nil
148 (ui-manager ui-manager)
149 (action-group action-group))
150
151(defbinding ui-manager-get-widget () widget
152 (ui-manager ui-manager)
153 (path string))
154
155(defbinding ui-manager-get-toplevels () (glist widget)
156 (ui-manager ui-manager)
157 (types ui-manager-item-type))
158
159(defbinding ui-manager-get-action () action
160 (ui-manager ui-manager)
161 (path string))
162
163(defbinding %ui-manager-add-ui-from-string (ui-manager ui) int
164 (ui-manager ui-manager)
165 (ui string)
166 ((length ui) int)
167 (gerror pointer :out))
168
169(defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec string))
170 (let ((id (%ui-manager-add-ui-from-string ui-manager ui-spec)))
171 (when (zerop id)
172 (error "We need to handle GError in som way"))
173 id))
174
175(defbinding %ui-manager-add-ui-from-file () int
176 (ui-manager ui-manager)
177 (filename pathname)
178 (gerror pointer :out))
179
180(defmethod ui-manager-add-ui ((ui-manager ui-manager) (path pathname))
181 (let ((id (%ui-manager-add-ui-from-file ui-manager path)))
182 (when (zerop id)
183 (error "We need to handle GError in som way"))
184 id))
185
186(defbinding %ui-manager-new-merge-id () unsigned-int
187 (ui-manager ui-manager))
188
189(defbinding %ui-manager-add-ui () nil
190 (ui-manager ui-manager)
191 (merge-id unsigned-int)
192 (path string)
193 (name string)
194 (action (or null string))
195 (type ui-manager-item-type)
196 (top boolean))
197
198(defvar *valid-ui-elements*
199 '((:ui :menubar :toolbar :popup :accelerator)
200 (:menubar :menuitem :separator :placeholder :menu)
201 (:menu :menuitem :separator :placehoder :menu)
202 (:popup :menuitem :separator :placehoder :menu)
203 (:toolbar :toolitem :separator :placehoder)
204 (:placeholder :menuitem :toolitem :separator :placeholder :menu)
205 (:menuitem)
206 (:toolitem)
207 (:separator)
208 (:accelerator)))
209
210(defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec list))
211 (let ((id (%ui-manager-new-merge-id ui-manager)))
212 (labels
213 ((parse-ui-spec (path ui-spec element)
214 (loop
215 for definition in ui-spec
216 do (destructuring-bind (type &optional name &rest rest)
217 (mklist definition)
218 (cond
219 ((not (find type (cdr (assoc element *valid-ui-elements*))))
220 (ui-manager-remove-ui ui-manager id)
221 (error "~S not valid subelement in ~S" type element))
222 ((multiple-value-bind (action children)
223 (if (and rest (atom (first rest))
224 (not (keywordp (first rest))))
225 (values (first rest) (rest rest))
226 (values name rest))
227 (%ui-manager-add-ui ui-manager id (or path "/") name action type nil)
228 (when children
229 (parse-ui-spec (concatenate 'string path "/" name)
230 children type)))))))))
231 (parse-ui-spec nil ui-spec :ui))
232 id))
233
234(defbinding ui-manager-remove-ui () nil
235 (ui-manager ui-manager)
236 (merge-id unsigned-int))
237
238(defbinding ui-manager-get-ui () string
239 (ui-manager ui-manager))
240
241(defbinding ui-manager-ensure-update () nil
242 (ui-manager ui-manager))