d32ee07b |
1 | ;; Common Lisp bindings for GTK+ v2.x |
2 | ;; Copyright 2006 Espen S. Johnsen <espen@users.sf.net> |
3 | ;; |
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: |
11 | ;; |
12 | ;; The above copyright notice and this permission notice shall be |
13 | ;; included in all copies or substantial portions of the Software. |
14 | ;; |
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. |
22 | |
6d747b3c |
23 | ;; $Id: glade-xml.lisp,v 1.3 2006-09-28 10:21:29 espen Exp $ |
d32ee07b |
24 | |
25 | |
26 | (in-package "GLADE-XML") |
27 | |
28 | |
29 | (defmethod build-interface ((interface cons)) |
30 | (unless (eq (first interface) :|glade-interface|) |
31 | (error "Not a valid interface specification")) |
32 | |
33 | (let ((toplevels (loop |
34 | for spec in (rest interface) |
35 | collect (ecase (first (mklist (first spec))) |
36 | (:|widget| (build-widget spec)))))) |
37 | (connect-signals toplevels toplevels) |
38 | toplevels)) |
39 | |
40 | (defmethod build-interface ((interface string)) |
41 | (build-interface (parse-xml-string interface))) |
42 | |
43 | (defmethod build-interface ((interface stream)) |
44 | (build-interface (parse-xml interface))) |
45 | |
46 | (defmethod build-interface ((interface pathname)) |
47 | (build-interface (parse-xml-file interface))) |
48 | |
49 | (defun load-interface (filename) |
50 | (build-interface (parse-xml-file filename))) |
51 | |
52 | |
53 | |
54 | (define-type-generic parse-value (type value)) |
55 | |
56 | (define-type-method parse-value ((type string) value) |
57 | (declare (ignore type)) |
58 | (or value "")) |
59 | |
60 | (define-type-method parse-value ((type number) value) |
61 | (declare (ignore type)) |
62 | (parse-number value)) |
63 | |
64 | (define-type-method parse-value ((type boolean) value) |
65 | (declare (ignore type)) |
66 | (and (member value '("true" "yes") :test #'string-equal) t)) |
67 | |
68 | |
69 | (defun find-enum-value (value type) |
6d747b3c |
70 | (second |
71 | (or |
72 | (assoc value (query-enum-values type nil) :test #'string=) |
73 | (assoc value (query-enum-values type :nickname) :test #'string=)))) |
d32ee07b |
74 | |
75 | (define-type-method parse-value ((type enum) value) |
76 | (int-enum (find-enum-value value type) type)) |
77 | |
78 | (define-type-method parse-value ((type flags) value) |
79 | (int-enum |
80 | (reduce #'logior |
81 | (mapcar |
82 | #'(lambda (flag) |
83 | (find-enum-value (string-trim " " flag) type)) |
84 | (split-string value :delimiter #\|))) |
85 | type)) |
86 | |
87 | |
88 | |
89 | (define-type-generic get-property-info (type value)) |
90 | |
91 | (defun %get-property-info (class pname) |
92 | (let ((slotd (find-if |
93 | #'(lambda (slotd) |
94 | (and |
95 | (or |
96 | (typep slotd 'effective-property-slot-definition) |
97 | (typep slotd 'gtk::effective-child-slot-definition)) |
98 | (string= pname (slot-definition-pname slotd)))) |
99 | (class-slots class)))) |
100 | (if (not slotd) |
101 | (warn "Ignoring unknown property for ~A: ~A" (class-name class) pname) |
102 | (values |
103 | (or |
104 | (first (mklist (slot-definition-initargs slotd))) |
105 | (warn "Ignoring property without initarg: ~A" pname)) |
106 | (slot-definition-type slotd))))) |
107 | |
108 | (define-type-method get-property-info ((type gobject) pname) |
109 | (%get-property-info (find-class type) pname)) |
110 | |
111 | (define-type-method get-property-info ((type gtk::container-child) pname) |
112 | (%get-property-info (find-class type) pname)) |
113 | |
114 | (define-type-method get-property-info ((type widget) pname) |
115 | (if (string= pname "visible") |
116 | (values :visible 'boolean) |
117 | (funcall (gffi::find-next-type-method 'get-property-info 'widget) type pname))) |
118 | |
119 | (define-type-method get-property-info ((type menu-item) pname) |
120 | (cond |
121 | ((string= pname "label") (values :label 'string)) |
122 | ((string= pname "use-underline") (values :use-underline 'boolean)) |
123 | ((string= pname "use-stock") (values :use-stock 'boolean)) |
124 | (t (funcall (gffi::find-next-type-method 'get-property-info 'menu-item) type pname)))) |
125 | |
126 | |
127 | |
128 | (defun parse-property (class attributes body) |
129 | (let ((pname (substitute #\- #\_ (getf attributes :|name|)))) |
130 | (multiple-value-bind (initarg type) (get-property-info (class-name class) pname) |
131 | (when initarg |
132 | (let ((parsed-value (handler-case (parse-value type (first body)) |
133 | (serious-condition (condition) |
134 | (declare (ignore condition)) |
6d747b3c |
135 | (warn "Ignoring property for ~A with unhandled type or invalid value: ~A" (class-name class) pname) |
d32ee07b |
136 | (return-from parse-property))))) |
137 | (list initarg parsed-value)))))) |
138 | |
139 | (defun parse-properties (class properites) |
140 | (unless (class-finalized-p class) |
141 | (finalize-inheritance class)) |
142 | |
143 | (loop |
144 | for (tag . body) in properites |
145 | as id = (first (mklist tag)) |
146 | as attributes = (rest (mklist tag)) |
147 | as arg = (when (eq id :|property|) |
148 | (parse-property class attributes body)) |
149 | when arg |
150 | nconc arg)) |
151 | |
152 | |
153 | (defmethod add-child ((parent container) (child widget) args) |
154 | (apply #'container-add parent child args)) |
155 | |
156 | (defmethod add-child ((menu-item menu-item) (menu menu) args) |
157 | (declare (ignore args)) |
158 | (setf (menu-item-submenu menu-item) menu)) |
159 | |
160 | |
161 | |
162 | (defun build-widget (spec) |
163 | (let* ((attributes (rest (first spec))) |
164 | (class (find-class (type-from-glib-name (getf attributes :|class|)))) |
165 | (id (getf attributes :|id|))) |
166 | |
167 | ;; Get properties and create widget |
168 | (let* ((initargs (parse-properties class (rest spec))) |
169 | (widget (apply #'make-instance class :name id initargs))) |
170 | |
171 | (loop |
172 | for (tag . body) in (rest spec) |
173 | as element = (first (mklist tag)) |
174 | as attributes = (rest (mklist tag)) |
175 | do (cond |
176 | ((and (eq element :|child|) (not (eq (first body) :|placeholder|))) |
177 | (let ((initargs (parse-properties (container-child-class class) (rest (second body))))) |
178 | (add-child widget (build-widget (first body)) initargs))) |
179 | |
180 | ((eq element :|signal|) |
181 | (let ((name (getf attributes :|name|)) |
182 | (callback (intern-with-package-prefix (string-upcase (getf attributes :|handler|)))) |
183 | (after (parse-value 'boolean (getf attributes :|after|))) |
184 | (object (or (getf attributes :|object|) t))) |
185 | ;; We can't connect the signal at this point because the |
186 | ;; name object may not yet have been created, so we |
187 | ;; store it as user data until all widgets are created |
188 | (push |
189 | (list name callback :after after :object object) |
190 | (user-data widget 'signals)))))) |
191 | widget))) |
192 | |
193 | |
194 | (defun intern-with-package-prefix (name) |
195 | (let ((pos (position #\: name))) |
196 | (if pos |
197 | (intern (subseq name (1+ pos))(subseq name 0 pos)) |
198 | (intern name)))) |
199 | |
200 | |
201 | (defun connect-signals (widgets toplevels) |
202 | (loop |
203 | for widget in widgets |
204 | do |
205 | (loop |
206 | for signal in (user-data widget 'signals) |
80722817 |
207 | do (destructuring-bind (name callback &key after object) signal |
6d747b3c |
208 | (signal-connect widget name callback :after after |
209 | :object (if (eq object t) |
210 | widget |
211 | (widget-find object toplevels))))) |
d32ee07b |
212 | (unset-user-data widget 'signals) |
213 | (when (typep widget 'container) |
214 | (connect-signals (container-children widget) toplevels)))) |