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.4 2008-10-09 18:45:33 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 (find-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))))