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