gtk/gtk.child-properties.lisp

   1 (in-package :gtk)
   2
   3 (defcfun gtk-container-child-get-property :void
   4   (container g-object)
   5   (child g-object)
   6   (property-name :string)
   7   (value (:pointer g-value)))
   8
   9 (defcfun gtk-container-child-set-property :void
  10   (container g-object)
  11   (child g-object)
  12   (property-name :string)
  13   (value (:pointer g-value)))
  14
  15 (defcfun gtk-container-class-find-child-property :pointer
  16   (class :pointer)
  17   (property-name :string))
  18
  19 (defun container-child-property-info (type property-name)
  20   (let ((class (g-type-class-ref type)))
  21     (unwind-protect
  22          (let ((g-param-spec (gtk-container-class-find-child-property class property-name)))
  23            (parse-g-param-spec g-param-spec))
  24       (g-type-class-unref class))))
  25
  26 (export 'container-child-property-info)
  27
  28 (defun container-call-get-property (container child property-name type)
  29   (with-foreign-object (gvalue 'g-value)
  30     (g-value-zero gvalue)
  31     (g-value-init gvalue (gtype type))
  32     (gtk-container-child-get-property container child property-name gvalue)
  33     (prog1 (parse-g-value gvalue)
  34       (g-value-unset gvalue))))
  35
  36 (defun container-call-set-property (container child property-name new-value type)
  37   (with-foreign-object (gvalue 'g-value)
  38     (set-g-value gvalue new-value (gtype type) :zero-g-value t)
  39     (gtk-container-child-set-property container child property-name gvalue)
  40     (g-value-unset gvalue)
  41     (values)))
  42
  43 (export '(container-call-get-property container-call-set-property))
  44
  45 (defmacro define-child-property (container-type property-name property-gname property-type readable writable export)
  46   (when (stringp container-type) (setf container-type (registered-object-type-by-name container-type)))
  47   `(progn
  48      ,@(when readable
  49              (list `(defun ,property-name (container child)
  50                       (assert (typep container ',container-type))
  51                       (container-call-get-property container child ,property-gname ,property-type))))
  52      ,@(when writable
  53              (list `(defun (setf ,property-name) (new-value container child)
  54                       (assert (typep container ',container-type))
  55                       (container-call-set-property container child ,property-gname new-value ,property-type))))
  56      ,@(when export
  57              (list `(export ',property-name)))))
  58
  59 (defcfun gtk-container-class-list-child-properties (:pointer (:pointer g-param-spec))
  60   (class (:pointer g-object-class))
  61   (n-properties (:pointer :int)))
  62
  63 (defun container-class-child-properties (g-type)
  64   (setf g-type (gtype g-type))
  65   (let ((g-class (g-type-class-ref g-type)))
  66     (unwind-protect
  67          (with-foreign-object (n-properties :uint)
  68            (let ((params (gtk-container-class-list-child-properties g-class n-properties)))
  69              (unwind-protect
  70                   (loop
  71                      for i from 0 below (mem-ref n-properties :uint)
  72                      for param = (mem-aref params :pointer i)
  73                      collect (parse-g-param-spec param))
  74                (g-free params))))
  75       (g-type-class-unref g-class))))
  76
  77 (defun child-property-name (type-name property-name package-name)
  78   (intern (format nil "~A-CHILD-~A" (symbol-name (registered-object-type-by-name type-name)) (string-upcase property-name)) (find-package package-name)))
  79
  80 (defun generate-child-properties (&optional (type-root "GtkContainer") (package-name "GTK"))
  81   (setf type-root (gtype type-root))
  82   (append (loop
  83              for property in (container-class-child-properties type-root)
  84              collect
  85                `(define-child-property
  86                     ,(gtype-name type-root)
  87                     ,(child-property-name (gtype-name type-root) (g-class-property-definition-name property) package-name)
  88                   ,(g-class-property-definition-name property)
  89                   ,(gtype-name (g-class-property-definition-type property))
  90                   ,(g-class-property-definition-readable property)
  91                   ,(g-class-property-definition-writable property)
  92                   t))
  93           (loop
  94              for subclass in (g-type-children type-root)
  95              appending (generate-child-properties subclass package-name))))