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 | |
23 | ;; $Id: glade-xml.lisp,v 1.1 2006-09-05 13:55:01 espen Exp $ |
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) |
70 | (second (assoc value (query-enum-values type nil) :test #'string=))) |
71 | |
72 | (define-type-method parse-value ((type enum) value) |
73 | (int-enum (find-enum-value value type) type)) |
74 | |
75 | (define-type-method parse-value ((type flags) value) |
76 | (int-enum |
77 | (reduce #'logior |
78 | (mapcar |
79 | #'(lambda (flag) |
80 | (find-enum-value (string-trim " " flag) type)) |
81 | (split-string value :delimiter #\|))) |
82 | type)) |
83 | |
84 | |
85 | |
86 | (define-type-generic get-property-info (type value)) |
87 | |
88 | (defun %get-property-info (class pname) |
89 | (let ((slotd (find-if |
90 | #'(lambda (slotd) |
91 | (and |
92 | (or |
93 | (typep slotd 'effective-property-slot-definition) |
94 | (typep slotd 'gtk::effective-child-slot-definition)) |
95 | (string= pname (slot-definition-pname slotd)))) |
96 | (class-slots class)))) |
97 | (if (not slotd) |
98 | (warn "Ignoring unknown property for ~A: ~A" (class-name class) pname) |
99 | (values |
100 | (or |
101 | (first (mklist (slot-definition-initargs slotd))) |
102 | (warn "Ignoring property without initarg: ~A" pname)) |
103 | (slot-definition-type slotd))))) |
104 | |
105 | (define-type-method get-property-info ((type gobject) pname) |
106 | (%get-property-info (find-class type) pname)) |
107 | |
108 | (define-type-method get-property-info ((type gtk::container-child) pname) |
109 | (%get-property-info (find-class type) pname)) |
110 | |
111 | (define-type-method get-property-info ((type widget) pname) |
112 | (if (string= pname "visible") |
113 | (values :visible 'boolean) |
114 | (funcall (gffi::find-next-type-method 'get-property-info 'widget) type pname))) |
115 | |
116 | (define-type-method get-property-info ((type menu-item) pname) |
117 | (cond |
118 | ((string= pname "label") (values :label 'string)) |
119 | ((string= pname "use-underline") (values :use-underline 'boolean)) |
120 | ((string= pname "use-stock") (values :use-stock 'boolean)) |
121 | (t (funcall (gffi::find-next-type-method 'get-property-info 'menu-item) type pname)))) |
122 | |
123 | |
124 | |
125 | (defun parse-property (class attributes body) |
126 | (let ((pname (substitute #\- #\_ (getf attributes :|name|)))) |
127 | (multiple-value-bind (initarg type) (get-property-info (class-name class) pname) |
128 | (when initarg |
129 | (let ((parsed-value (handler-case (parse-value type (first body)) |
130 | (serious-condition (condition) |
131 | (declare (ignore condition)) |
132 | (warn "Ignoring property with unhandled type or invalid value: ~A" pname) |
133 | (return-from parse-property))))) |
134 | (list initarg parsed-value)))))) |
135 | |
136 | (defun parse-properties (class properites) |
137 | (unless (class-finalized-p class) |
138 | (finalize-inheritance class)) |
139 | |
140 | (loop |
141 | for (tag . body) in properites |
142 | as id = (first (mklist tag)) |
143 | as attributes = (rest (mklist tag)) |
144 | as arg = (when (eq id :|property|) |
145 | (parse-property class attributes body)) |
146 | when arg |
147 | nconc arg)) |
148 | |
149 | |
150 | (defmethod add-child ((parent container) (child widget) args) |
151 | (apply #'container-add parent child args)) |
152 | |
153 | (defmethod add-child ((menu-item menu-item) (menu menu) args) |
154 | (declare (ignore args)) |
155 | (setf (menu-item-submenu menu-item) menu)) |
156 | |
157 | |
158 | |
159 | (defun build-widget (spec) |
160 | (let* ((attributes (rest (first spec))) |
161 | (class (find-class (type-from-glib-name (getf attributes :|class|)))) |
162 | (id (getf attributes :|id|))) |
163 | |
164 | ;; Get properties and create widget |
165 | (let* ((initargs (parse-properties class (rest spec))) |
166 | (widget (apply #'make-instance class :name id initargs))) |
167 | |
168 | (loop |
169 | for (tag . body) in (rest spec) |
170 | as element = (first (mklist tag)) |
171 | as attributes = (rest (mklist tag)) |
172 | do (cond |
173 | ((and (eq element :|child|) (not (eq (first body) :|placeholder|))) |
174 | (let ((initargs (parse-properties (container-child-class class) (rest (second body))))) |
175 | (add-child widget (build-widget (first body)) initargs))) |
176 | |
177 | ((eq element :|signal|) |
178 | (let ((name (getf attributes :|name|)) |
179 | (callback (intern-with-package-prefix (string-upcase (getf attributes :|handler|)))) |
180 | (after (parse-value 'boolean (getf attributes :|after|))) |
181 | (object (or (getf attributes :|object|) t))) |
182 | ;; We can't connect the signal at this point because the |
183 | ;; name object may not yet have been created, so we |
184 | ;; store it as user data until all widgets are created |
185 | (push |
186 | (list name callback :after after :object object) |
187 | (user-data widget 'signals)))))) |
188 | widget))) |
189 | |
190 | |
191 | (defun intern-with-package-prefix (name) |
192 | (let ((pos (position #\: name))) |
193 | (if pos |
194 | (intern (subseq name (1+ pos))(subseq name 0 pos)) |
195 | (intern name)))) |
196 | |
197 | |
198 | (defun connect-signals (widgets toplevels) |
199 | (loop |
200 | for widget in widgets |
201 | do |
202 | (loop |
203 | for signal in (user-data widget 'signals) |
204 | do (destructuring-bind (handler-id name callback &key after object) signal |
205 | (signal-connect widget name callback :after after :object (widget-find object toplevels)))) |
206 | (unset-user-data widget 'signals) |
207 | (when (typep widget 'container) |
208 | (connect-signals (container-children widget) toplevels)))) |