chiark / gitweb /
Initial checkin
[clg] / glade-xml / glade-xml.lisp
CommitLineData
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))))