3 (defcfun gtk-container-child-get-property :void
6 (property-name :string)
7 (value (:pointer g-value)))
9 (defcfun gtk-container-child-set-property :void
12 (property-name :string)
13 (value (:pointer g-value)))
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))))
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)
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)))
34 (list `(defun ,property-name (container child)
35 (assert (typep container ',container-type))
36 (container-call-get-property container child ,property-gname ,property-type))))
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))))
42 (list `(export ',property-name)))))
44 (defcfun gtk-container-class-list-child-properties (:pointer (:pointer g-param-spec))
45 (class (:pointer g-object-class))
46 (n-properties (:pointer :int)))
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)))
52 (with-foreign-object (n-properties :uint)
53 (let ((params (gtk-container-class-list-child-properties g-class n-properties)))
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))
60 (g-type-class-unref g-class))))
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)))
65 (defun generate-child-properties (&optional (type-root "GtkContainer") (package-name "GTK"))
66 (setf type-root (ensure-g-type type-root))
68 for property in (container-class-child-properties type-root)
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)
79 for subclass in (g-type-children type-root)
80 appending (generate-child-properties subclass package-name))))