| 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.3 2006-09-28 10:21:29 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 |
| 71 | (or |
| 72 | (assoc value (query-enum-values type nil) :test #'string=) |
| 73 | (assoc value (query-enum-values type :nickname) :test #'string=)))) |
| 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)) |
| 135 | (warn "Ignoring property for ~A with unhandled type or invalid value: ~A" (class-name class) pname) |
| 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) |
| 207 | do (destructuring-bind (name callback &key after object) signal |
| 208 | (signal-connect widget name callback :after after |
| 209 | :object (if (eq object t) |
| 210 | widget |
| 211 | (widget-find object toplevels))))) |
| 212 | (unset-user-data widget 'signals) |
| 213 | (when (typep widget 'container) |
| 214 | (connect-signals (container-children widget) toplevels)))) |