chiark - git - mdw - clg/blob - glade-xml/glade-xml.lisp

   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.2 2006-09-27 08:44:44 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 (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))))