glib/gobject.gvalue.lisp

   1 (in-package :gobject)
   2
   3 (defun g-value-zero (g-value)
   4   "Initializes the GValue in \"unset\" state.
   5
   6 @arg[g-value]{a C pointer to the GValue structure}"
   7   (loop
   8      for i from 0 below (foreign-type-size 'g-value)
   9      do (setf (mem-ref g-value :uchar i) 0)))
  10
  11 (defun gvalue-type (gvalue)
  12   (foreign-slot-value gvalue 'g-value :type))
  13
  14 (defmacro ev-case (keyform &body clauses)
  15   "Macro that is an analogue of CASE except that it evaluates keyforms"
  16   (let ((value (gensym)))
  17     `(let ((,value ,keyform))
  18        (cond
  19          ,@(loop
  20               for (key . forms) in clauses
  21               collect
  22                 (if (eq key t)
  23                     `(t ,@forms)
  24                     `((equalp ,key ,value) ,@forms)))))))
  25
  26 (defgeneric parse-gvalue-for-type (gvalue-ptr type-numeric))
  27
  28 (defmethod parse-gvalue-for-type (gvalue-ptr type-numeric)
  29   (if (= type-numeric (g-type-numeric (g-type-fundamental type-numeric)))
  30       (call-next-method)
  31       (parse-gvalue-for-type gvalue-ptr (g-type-numeric (g-type-fundamental type-numeric)))))
  32
  33 (defun parse-gvalue (gvalue)
  34   "Parses the GValue structure and returns the corresponding Lisp object.
  35
  36 @arg[value]{a C pointer to the GValue structure}
  37 @return{value contained in the GValue structure. Type of value depends on GValue type}"
  38   (let* ((type (g-type-numeric (gvalue-type gvalue)))
  39          (fundamental-type (g-type-numeric (g-type-fundamental type))))
  40     (ev-case fundamental-type
  41       (+g-type-invalid+ (error "GValue is of invalid type (~A)" (g-type-name type)))
  42       (+g-type-void+ nil)
  43       (+g-type-char+ (g-value-get-char gvalue))
  44       (+g-type-uchar+ (g-value-get-uchar gvalue))
  45       (+g-type-boolean+ (g-value-get-boolean gvalue))
  46       (+g-type-int+ (g-value-get-int gvalue))
  47       (+g-type-uint+ (g-value-get-uint gvalue))
  48       (+g-type-long+ (g-value-get-long gvalue))
  49       (+g-type-ulong+ (g-value-get-ulong gvalue))
  50       (+g-type-int64+ (g-value-get-int64 gvalue))
  51       (+g-type-uint64+ (g-value-get-uint64 gvalue))
  52       (+g-type-enum+ (parse-gvalue-enum gvalue))
  53       (+g-type-flags+ (parse-gvalue-flags gvalue))
  54       (+g-type-float+ (g-value-get-float gvalue))
  55       (+g-type-double+ (g-value-get-double gvalue))
  56       (+g-type-string+ (g-value-get-string gvalue))
  57       (t (parse-gvalue-for-type gvalue type)))))
  58
  59 (defmethod parse-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-pointer+)))
  60   (g-value-get-pointer gvalue-ptr))
  61
  62 (defmethod parse-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)))
  63   (if (= (g-type-numeric (gvalue-type gvalue-ptr)) type-numeric)
  64       (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
  65       (parse-gvalue-boxed gvalue-ptr)))
  66
  67 (defmethod parse-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-param+)))
  68   (parse-g-param-spec (g-value-get-param gvalue-ptr)))
  69
  70 (defmethod parse-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-object+)))
  71   (parse-gvalue-object gvalue-ptr))
  72
  73 (defmethod parse-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-interface+)))
  74   (parse-gvalue-object gvalue-ptr))
  75
  76 (defgeneric set-gvalue-for-type (gvalue-ptr type-numeric value))
  77
  78 (defmethod set-gvalue-for-type (gvalue-ptr type-numeric value)
  79   (if (= type-numeric (g-type-numeric (g-type-fundamental type-numeric)))
  80       (call-next-method)
  81       (set-gvalue-for-type gvalue-ptr (g-type-numeric (g-type-fundamental type-numeric)) value)))
  82
  83 (defun set-g-value (gvalue value type &key zero-g-value unset-g-value (g-value-init t))
  84   "Assigns the GValue structure @code{gvalue} the value @code{value} of GType @code{type}.
  85
  86 @arg[gvalue]{a C pointer to the GValue structure}
  87 @arg[value]{a Lisp object that is to be assigned}
  88 @arg[type]{a GType that is to be assigned}
  89 @arg[zero-g-value]{a boolean specifying whether GValue should be zero-initialized before assigning. See @fun{g-value-zero}}
  90 @arg[unset-g-value]{a boolean specifying whether GValue should be \"unset\" before assigning. See @fun{g-value-unset}. The \"true\" value should not be passed to both @code{zero-g-value} and @code{unset-g-value} arguments}
  91 @arg[g-value-init]{a boolean specifying where GValue should be initialized}"
  92   (setf type (g-type-numeric type))
  93   (cond
  94     (zero-g-value (g-value-zero gvalue))
  95     (unset-g-value (g-value-unset gvalue)))
  96   (when g-value-init (g-value-init gvalue type))
  97   (let ((fundamental-type (ensure-g-type (g-type-fundamental type))))
  98     (ev-case fundamental-type
  99       (+g-type-invalid+ (error "Invalid type (~A)" type))
 100       (+g-type-void+ nil)
 101       (+g-type-char+ (g-value-set-char gvalue value))
 102       (+g-type-uchar+ (g-value-set-uchar gvalue value))
 103       (+g-type-boolean+ (g-value-set-boolean gvalue value))
 104       (+g-type-int+ (g-value-set-int gvalue value))
 105       (+g-type-uint+ (g-value-set-uint gvalue value))
 106       (+g-type-long+ (g-value-set-long gvalue value))
 107       (+g-type-ulong+ (g-value-set-ulong gvalue value))
 108       (+g-type-int64+ (g-value-set-int64 gvalue value))
 109       (+g-type-uint64+ (g-value-set-uint64 gvalue value))
 110       (+g-type-enum+ (set-gvalue-enum gvalue value))
 111       (+g-type-flags+ (set-gvalue-flags gvalue value))
 112       (+g-type-float+ (unless (realp value) (error "~A is not a real number" value)) (g-value-set-float gvalue (coerce value 'single-float)))
 113       (+g-type-double+ (unless (realp value) (error "~A is not a real number" value)) (g-value-set-double gvalue (coerce value 'double-float)))
 114       (+g-type-string+ (g-value-set-string gvalue value))
 115       (t (set-gvalue-for-type gvalue type value)))))
 116
 117 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-pointer+)) value)
 118   (g-value-set-pointer gvalue-ptr value))
 119
 120 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) value)
 121   (if (= (g-type-numeric (gvalue-type gvalue-ptr)) type-numeric)
 122       (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
 123       (set-gvalue-boxed gvalue-ptr value)))
 124
 125 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-param+)) value)
 126   (error "Setting of GParam is not implemented"))
 127
 128 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-object+)) value)
 129   (set-gvalue-object gvalue-ptr value))
 130
 131 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-interface+)) value)
 132   (set-gvalue-object gvalue-ptr value))
 133
 134 ;;Enums
 135
 136 (defvar *registered-enum-types* (make-hash-table :test 'equal))
 137 (defun register-enum-type (name type)
 138   (setf (gethash name *registered-enum-types*) type))
 139 (defun registered-enum-type (name)
 140   (gethash name *registered-enum-types*))
 141
 142 (defun parse-gvalue-enum (gvalue)
 143   (let* ((g-type (gvalue-type gvalue))
 144          (type-name (g-type-name g-type))
 145          (enum-type (registered-enum-type type-name)))
 146     (unless enum-type
 147       (error "Enum ~A is not registered" type-name))
 148     (convert-from-foreign (g-value-get-enum gvalue) enum-type)))
 149
 150 (defun set-gvalue-enum (gvalue value)
 151   (let* ((g-type (gvalue-type gvalue))
 152          (type-name (g-type-name g-type))
 153          (enum-type (registered-enum-type type-name)))
 154     (unless enum-type
 155       (error "Enum ~A is not registered" type-name))
 156     (g-value-set-enum gvalue (convert-to-foreign value enum-type))))
 157
 158
 159 ;;Flags
 160
 161 (defvar *registered-flags-types* (make-hash-table :test 'equal))
 162 (defun register-flags-type (name type)
 163   (setf (gethash name *registered-flags-types*) type))
 164 (defun registered-flags-type (name)
 165   (gethash name *registered-flags-types*))
 166
 167 (defun parse-gvalue-flags (gvalue)
 168   (let* ((g-type (gvalue-type gvalue))
 169          (type-name (g-type-name g-type))
 170          (flags-type (registered-flags-type type-name)))
 171     (unless flags-type
 172       (error "Flags ~A is not registered" type-name))
 173     (convert-from-foreign (g-value-get-flags gvalue) flags-type)))
 174
 175 (defun set-gvalue-flags (gvalue value)
 176   (let* ((g-type (gvalue-type gvalue))
 177          (type-name (g-type-name g-type))
 178          (flags-type (registered-flags-type type-name)))
 179     (unless flags-type
 180       (error "Flags ~A is not registered" type-name))
 181     (g-value-set-flags gvalue (convert-to-foreign value flags-type))))
 182
 183 ;;Objects
 184
 185 (defun parse-gvalue-object (gvalue)
 186   (get-g-object-for-pointer (g-value-get-object gvalue)))
 187
 188 (defun set-gvalue-object (gvalue value)
 189   (g-value-set-object gvalue (if value (pointer value) (null-pointer))))