3 (defun gvalue-type (gvalue)
4 (foreign-slot-value gvalue 'g-value 'type))
6 (defmacro ev-case (keyform &body clauses)
7 "Macro that is an analogue of CASE except that it evaluates keyforms"
8 (let ((value (gensym)))
9 `(let ((,value ,keyform))
12 for (key . forms) in clauses
16 `((equalp ,key ,value) ,@forms)))))))
18 (defun parse-gvalue (gvalue)
19 (let* ((type (gvalue-type gvalue))
20 (fundamental-type (g-type-fundamental type)))
22 ((= type (g-strv-get-type)) (convert-from-foreign (g-value-get-boxed gvalue) '(glib:gstrv :free-from-foreign nil)))
23 (t (ev-case fundamental-type
24 (+g-type-invalid+ (error "GValue is of invalid type (~A)" (g-type-name type)))
26 (+g-type-char+ (g-value-get-char gvalue))
27 (+g-type-uchar+ (g-value-get-uchar gvalue))
28 (+g-type-boolean+ (g-value-get-boolean gvalue))
29 (+g-type-int+ (g-value-get-int gvalue))
30 (+g-type-uint+ (g-value-get-uint gvalue))
31 (+g-type-long+ (g-value-get-long gvalue))
32 (+g-type-ulong+ (g-value-get-ulong gvalue))
33 (+g-type-int64+ (g-value-get-int64 gvalue))
34 (+g-type-uint64+ (g-value-get-uint64 gvalue))
35 (+g-type-enum+ (parse-gvalue-enum gvalue))
36 (+g-type-flags+ (parse-gvalue-flags gvalue))
37 (+g-type-float+ (g-value-get-float gvalue))
38 (+g-type-double+ (g-value-get-double gvalue))
39 (+g-type-string+ (g-value-get-string gvalue))
40 (+g-type-pointer+ (g-value-get-pointer gvalue))
41 (+g-type-boxed+ (parse-gvalue-boxed gvalue))
42 ;(+g-type-param+ (parse-gvalue-param gvalue))
43 (+g-type-object+ (parse-gvalue-object gvalue))
44 (+g-type-interface+ (parse-gvalue-object gvalue))
45 (t (error "Unknown type: ~A (~A)" type (g-type-name type))))))))
47 (defun set-g-value (gvalue value type &key zero-g-value unset-g-value (g-value-init t))
49 (zero-g-value (g-value-zero gvalue))
50 (unset-g-value (g-value-unset gvalue)))
51 (when g-value-init (g-value-init gvalue type))
52 (let ((fundamental-type (g-type-fundamental type)))
54 ((= type (g-strv-get-type)) (g-value-set-boxed gvalue (convert-to-foreign value 'glib:gstrv)))
55 (t (ev-case fundamental-type
56 (+g-type-invalid+ (error "Invalid type (~A)" type))
58 (+g-type-char+ (g-value-set-char gvalue value))
59 (+g-type-uchar+ (g-value-set-uchar gvalue value))
60 (+g-type-boolean+ (g-value-set-boolean gvalue value))
61 (+g-type-int+ (g-value-set-int gvalue value))
62 (+g-type-uint+ (g-value-set-uint gvalue value))
63 (+g-type-long+ (g-value-set-long gvalue value))
64 (+g-type-ulong+ (g-value-set-ulong gvalue value))
65 (+g-type-int64+ (g-value-set-int64 gvalue value))
66 (+g-type-uint64+ (g-value-set-uint64 gvalue value))
67 (+g-type-enum+ (set-gvalue-enum gvalue value))
68 (+g-type-flags+ (set-gvalue-flags gvalue value))
69 (+g-type-float+ (unless (realp value) (error "~A is not a real number" value)) (g-value-set-float gvalue (coerce value 'single-float)))
70 (+g-type-double+ (unless (realp value) (error "~A is not a real number" value)) (g-value-set-double gvalue (coerce value 'double-float)))
71 (+g-type-string+ (g-value-set-string gvalue value))
72 (+g-type-pointer+ (g-value-set-pointer gvalue value))
73 (+g-type-boxed+ (set-gvalue-boxed gvalue value))
74 ;(+g-type-param+ (set-gvalue-param gvalue value))
75 (+g-type-object+ (set-gvalue-object gvalue value))
76 (+g-type-interface+ (set-gvalue-object gvalue value))
77 (t (error "Unknown type: ~A (~A)" type (g-type-name type))))))))
81 (defvar *registered-enum-types* (make-hash-table :test 'equal))
82 (defun register-enum-type (name type)
83 (setf (gethash name *registered-enum-types*) type))
84 (defun registered-enum-type (name)
85 (gethash name *registered-enum-types*))
87 (defun parse-gvalue-enum (gvalue)
88 (let* ((g-type (gvalue-type gvalue))
89 (type-name (g-type-name g-type))
90 (enum-type (registered-enum-type type-name)))
92 (error "Enum ~A is not registered" type-name))
93 (convert-from-foreign (g-value-get-enum gvalue) enum-type)))
95 (defun set-gvalue-enum (gvalue value)
96 (let* ((g-type (gvalue-type gvalue))
97 (type-name (g-type-name g-type))
98 (enum-type (registered-enum-type type-name)))
100 (error "Enum ~A is not registered" type-name))
101 (g-value-set-enum gvalue (convert-to-foreign value enum-type))))
106 (defvar *registered-flags-types* (make-hash-table :test 'equal))
107 (defun register-flags-type (name type)
108 (setf (gethash name *registered-flags-types*) type))
109 (defun registered-flags-type (name)
110 (gethash name *registered-flags-types*))
112 (defun parse-gvalue-flags (gvalue)
113 (let* ((g-type (gvalue-type gvalue))
114 (type-name (g-type-name g-type))
115 (flags-type (registered-flags-type type-name)))
117 (error "Flags ~A is not registered" type-name))
118 (convert-from-foreign (g-value-get-flags gvalue) flags-type)))
120 (defun set-gvalue-flags (gvalue value)
121 (let* ((g-type (gvalue-type gvalue))
122 (type-name (g-type-name g-type))
123 (flags-type (registered-flags-type type-name)))
125 (error "Flags ~A is not registered" type-name))
126 (g-value-set-flags gvalue (convert-to-foreign value flags-type))))
130 (defun parse-gvalue-object (gvalue)
131 (get-g-object-for-pointer (g-value-get-object gvalue)))
133 (defun set-gvalue-object (gvalue value)
134 (g-value-set-object gvalue (if value (pointer value) (null-pointer))))