1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
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.
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.
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
18 ;; $Id: gtkaction.lisp,v 1.3 2005/02/03 23:09:09 espen Exp $
25 (defmethod initialize-instance ((action action) &key accelerator)
27 (setf (object-data action 'accelerator) accelerator))
29 (defmethod action-accelerator ((action action))
30 (object-data action 'accelerator))
32 (defbinding (action-is-sensitive-p "gtk_action_is_sensitive") () boolean
35 (defbinding (action-is-visible-p "gtk_action_is_visible") () boolean
38 (defbinding action-activate () nil
44 (defmethod initialize-instance ((action-group action-group) &rest initargs
46 (declare (ignore action actions))
49 (initial-add action-group #'action-group-add-action
50 initargs :action :actions)))
52 (defbinding action-group-get-action () action
53 (action-group action-group)
56 (defbinding action-group-list-actions () (glist action)
57 (action-group action-group))
59 (defbinding %action-group-add-action () nil
60 (action-group action-group)
63 (defbinding %action-group-add-action-with-accel () nil
64 (action-group action-group)
66 (accelerator (or null string)))
68 (defun action-group-add-action (action-group action)
69 (multiple-value-bind (accelerator accelerator-p)
70 (object-data action 'accelerator)
72 (%action-group-add-action-with-accel action-group action accelerator)
73 (%action-group-add-action action-group action))))
75 (defbinding action-group-remove-action () nil
76 (action-group action-group)
82 (defmethod initialize-instance ((action radio-action) &key group value)
84 (setf (slot-value action '%value) (sap-int (proxy-location action)))
85 (setf (object-data action 'radio-action-value) value)
87 (radio-action-add-to-group action group)))
89 (defmethod radio-value-action ((action radio-action))
90 (object-data action 'radio-action-value))
92 (defbinding %radio-action-get-group () pointer
93 (radio-action radio-action))
95 (defbinding %radio-action-set-group () nil
96 (radio-button radio-button)
99 (defun radio-action-add-to-group (action1 action2)
100 "Add ACTION1 to the group which ACTION2 belongs to."
101 (%radio-action-set-group action1 (%radio-action-get-group action2)))
103 (defbinding (radio-action-get-current "gtk_radio_action_get_current_value")
105 (radio-action radio-action))
107 (defun radio-action-get-current-value (action)
108 (radio-value-action (radio-action-get-current action)))
114 (defbinding toggle-action-toggled () nil
115 (toggle-action toggle-action))
121 (defmethod initialize-instance ((ui-manager ui-manager) &rest initargs
122 &key ui action-group)
123 (declare (ignore ui action-group))
125 (mapc #'(lambda (action-group)
126 (ui-manager-insert-action-group ui-manager action-group))
127 (get-all initargs :action-group))
129 (ui-manager-add-ui ui-manager ui))
130 (get-all initargs :ui)))
133 (defbinding ui-manager-insert-action-group
134 (ui-manager action-group &optional (pos :end)) nil
135 (ui-manager ui-manager)
136 (action-group action-group)
142 (defbinding ui-manager-remove-action-group () nil
143 (ui-manager ui-manager)
144 (action-group action-group))
146 (defbinding ui-manager-get-widget () widget
147 (ui-manager ui-manager)
150 (defbinding ui-manager-get-toplevels () (glist widget)
151 (ui-manager ui-manager)
152 (types ui-manager-item-type))
154 (defbinding ui-manager-get-action () action
155 (ui-manager ui-manager)
158 (defbinding %ui-manager-add-ui-from-string (ui-manager ui) int
159 (ui-manager ui-manager)
162 (gerror pointer :out))
164 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec string))
165 (let ((id (%ui-manager-add-ui-from-string ui-manager ui-spec)))
167 (error "We need to handle GError in som way"))
170 (defbinding %ui-manager-add-ui-from-file () int
171 (ui-manager ui-manager)
173 (gerror pointer :out))
175 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (path pathname))
176 (let ((id (%ui-manager-add-ui-from-file ui-manager path)))
178 (error "We need to handle GError in som way"))
181 (defbinding %ui-manager-new-merge-id () unsigned-int
182 (ui-manager ui-manager))
184 (defbinding %ui-manager-add-ui () nil
185 (ui-manager ui-manager)
186 (merge-id unsigned-int)
189 (action (or null string))
190 (type ui-manager-item-type)
193 (defvar *valid-ui-elements*
194 '((:ui :menubar :toolbar :popup :accelerator)
195 (:menubar :menuitem :separator :placeholder :menu)
196 (:menu :menuitem :separator :placehoder :menu)
197 (:popup :menuitem :separator :placehoder :menu)
198 (:toolbar :toolitem :separator :placehoder)
199 (:placeholder :menuitem :toolitem :separator :placeholder :menu)
205 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec list))
206 (let ((id (%ui-manager-new-merge-id ui-manager)))
208 ((parse-ui-spec (path ui-spec element)
210 for definition in ui-spec
211 do (destructuring-bind (type &optional name &rest rest)
214 ((not (find type (cdr (assoc element *valid-ui-elements*))))
215 (ui-manager-remove-ui ui-manager id)
216 (error "~S not valid subelement in ~S" type element))
217 ((multiple-value-bind (action children)
218 (if (and rest (atom (first rest))
219 (not (keywordp (first rest))))
220 (values (first rest) (rest rest))
222 (%ui-manager-add-ui ui-manager id (or path "/") name action type nil)
224 (parse-ui-spec (concatenate 'string path "/" name)
225 children type)))))))))
226 (parse-ui-spec nil ui-spec :ui))
229 (defbinding ui-manager-remove-ui () nil
230 (ui-manager ui-manager)
231 (merge-id unsigned-int))
233 (defbinding ui-manager-get-ui () string
234 (ui-manager ui-manager))
236 (defbinding ui-manager-ensure-update () nil
237 (ui-manager ui-manager))