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 g-value-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-g-value-for-type (gvalue-ptr gtype parse-kind))
  27
  28 (defmethod parse-g-value-for-type :around (gvalue-ptr gtype parse-kind)
  29   (assert (typep gtype '(or gtype nil)))
  30   (call-next-method))
  31
  32 (defmethod parse-g-value-for-type (gvalue-ptr gtype parse-kind)
  33   (if (eq gtype (g-type-fundamental gtype))
  34       (call-next-method)
  35       (parse-g-value-for-type gvalue-ptr (g-type-fundamental gtype) parse-kind)))
  36
  37 (defun parse-g-value (gvalue &key (parse-kind :get-property))
  38   "Parses the GValue structure and returns the corresponding Lisp object.
  39
  40 @arg[value]{a C pointer to the GValue structure}
  41 @return{value contained in the GValue structure. Type of value depends on GValue type}"
  42   (let* ((type (g-value-type gvalue))
  43          (fundamental-type (g-type-fundamental type)))
  44     (ev-case fundamental-type
  45       ((gtype +g-type-invalid+) (error "GValue is of invalid type (~A)" (gtype-name type)))
  46       ((gtype +g-type-void+) nil)
  47       ((gtype +g-type-char+) (g-value-get-char gvalue))
  48       ((gtype +g-type-uchar+) (g-value-get-uchar gvalue))
  49       ((gtype +g-type-boolean+) (g-value-get-boolean gvalue))
  50       ((gtype +g-type-int+) (g-value-get-int gvalue))
  51       ((gtype +g-type-uint+) (g-value-get-uint gvalue))
  52       ((gtype +g-type-long+) (g-value-get-long gvalue))
  53       ((gtype +g-type-ulong+) (g-value-get-ulong gvalue))
  54       ((gtype +g-type-int64+) (g-value-get-int64 gvalue))
  55       ((gtype +g-type-uint64+) (g-value-get-uint64 gvalue))
  56       ((gtype +g-type-enum+) (parse-g-value-enum gvalue))
  57       ((gtype +g-type-flags+) (parse-g-value-flags gvalue))
  58       ((gtype +g-type-float+) (g-value-get-float gvalue))
  59       ((gtype +g-type-double+) (g-value-get-double gvalue))
  60       ((gtype +g-type-string+) (g-value-get-string gvalue))
  61       (t (parse-g-value-for-type gvalue type parse-kind)))))
  62
  63 (defmethod parse-g-value-for-type (gvalue-ptr (type (eql (gtype +g-type-pointer+))) parse-kind)
  64   (declare (ignore parse-kind))
  65   (g-value-get-pointer gvalue-ptr))
  66
  67 (defmethod parse-g-value-for-type (gvalue-ptr (type (eql (gtype +g-type-param+))) parse-kind)
  68   (declare (ignore parse-kind))
  69   (parse-g-param-spec (g-value-get-param gvalue-ptr)))
  70
  71 (defgeneric set-gvalue-for-type (gvalue-ptr type value))
  72
  73 (defmethod set-gvalue-for-type :around (gvalue-ptr type value)
  74   (assert (typep type '(or gtype null)))
  75   (call-next-method))
  76
  77 (defmethod set-gvalue-for-type (gvalue-ptr type value)
  78   (if (eq type (g-type-fundamental type))
  79       (call-next-method)
  80       (set-gvalue-for-type gvalue-ptr (g-type-fundamental type) value)))
  81
  82 (defun set-g-value (gvalue value type &key zero-g-value unset-g-value (g-value-init t))
  83   "Assigns the GValue structure @code{gvalue} the value @code{value} of GType @code{type}.
  84
  85 @arg[gvalue]{a C pointer to the GValue structure}
  86 @arg[value]{a Lisp object that is to be assigned}
  87 @arg[type]{a GType that is to be assigned}
  88 @arg[zero-g-value]{a boolean specifying whether GValue should be zero-initialized before assigning. See @fun{g-value-zero}}
  89 @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}
  90 @arg[g-value-init]{a boolean specifying where GValue should be initialized}"
  91   (setf type (gtype type))
  92   (cond
  93     (zero-g-value (g-value-zero gvalue))
  94     (unset-g-value (g-value-unset gvalue)))
  95   (when g-value-init (g-value-init gvalue type))
  96   (let ((fundamental-type (g-type-fundamental type)))
  97     (ev-case fundamental-type
  98       ((gtype +g-type-invalid+) (error "Invalid type (~A)" type))
  99       ((gtype +g-type-void+) nil)
 100       ((gtype +g-type-char+) (g-value-set-char gvalue value))
 101       ((gtype +g-type-uchar+) (g-value-set-uchar gvalue value))
 102       ((gtype +g-type-boolean+) (g-value-set-boolean gvalue value))
 103       ((gtype +g-type-int+) (g-value-set-int gvalue value))
 104       ((gtype +g-type-uint+) (g-value-set-uint gvalue value))
 105       ((gtype +g-type-long+) (g-value-set-long gvalue value))
 106       ((gtype +g-type-ulong+) (g-value-set-ulong gvalue value))
 107       ((gtype +g-type-int64+) (g-value-set-int64 gvalue value))
 108       ((gtype +g-type-uint64+) (g-value-set-uint64 gvalue value))
 109       ((gtype +g-type-enum+) (set-gvalue-enum gvalue value))
 110       ((gtype +g-type-flags+) (set-gvalue-flags gvalue value))
 111       ((gtype +g-type-float+) (unless (realp value) (error "~A is not a real number" value)) (g-value-set-float gvalue (coerce value 'single-float)))
 112       ((gtype +g-type-double+) (unless (realp value) (error "~A is not a real number" value)) (g-value-set-double gvalue (coerce value 'double-float)))
 113       ((gtype +g-type-string+) (g-value-set-string gvalue value))
 114       (t (set-gvalue-for-type gvalue type value)))))
 115
 116 (defmethod set-gvalue-for-type (gvalue-ptr (type (eql (gtype +g-type-pointer+))) value)
 117   (g-value-set-pointer gvalue-ptr value))
 118
 119 (defmethod set-gvalue-for-type (gvalue-ptr (type (eql (gtype +g-type-param+))) value)
 120   (declare (ignore gvalue-ptr value))
 121   (error "Setting of GParam is not implemented"))
 122
 123 ;;Enums
 124
 125 (defvar *registered-enum-types* (make-hash-table :test 'equal))
 126 (defun register-enum-type (name type)
 127   (setf (gethash name *registered-enum-types*) type))
 128 (defun registered-enum-type (name)
 129   (gethash name *registered-enum-types*))
 130
 131 (defun parse-g-value-enum (gvalue)
 132   (let* ((g-type (g-value-type gvalue))
 133          (type-name (gtype-name g-type))
 134          (enum-type (registered-enum-type type-name)))
 135     (unless enum-type
 136       (error "Enum ~A is not registered" type-name))
 137     (convert-from-foreign (g-value-get-enum gvalue) enum-type)))
 138
 139 (defun set-gvalue-enum (gvalue value)
 140   (let* ((g-type (g-value-type gvalue))
 141          (type-name (gtype-name g-type))
 142          (enum-type (registered-enum-type type-name)))
 143     (unless enum-type
 144       (error "Enum ~A is not registered" type-name))
 145     (g-value-set-enum gvalue (convert-to-foreign value enum-type))))
 146
 147
 148 ;;Flags
 149
 150 (defvar *registered-flags-types* (make-hash-table :test 'equal))
 151 (defun register-flags-type (name type)
 152   (setf (gethash name *registered-flags-types*) type))
 153 (defun registered-flags-type (name)
 154   (gethash name *registered-flags-types*))
 155
 156 (defun parse-g-value-flags (gvalue)
 157   (let* ((g-type (g-value-type gvalue))
 158          (type-name (gtype-name g-type))
 159          (flags-type (registered-flags-type type-name)))
 160     (unless flags-type
 161       (error "Flags ~A is not registered" type-name))
 162     (convert-from-foreign (g-value-get-flags gvalue) flags-type)))
 163
 164 (defun set-gvalue-flags (gvalue value)
 165   (let* ((g-type (g-value-type gvalue))
 166          (type-name (gtype-name g-type))
 167          (flags-type (registered-flags-type type-name)))
 168     (unless flags-type
 169       (error "Flags ~A is not registered" type-name))
 170     (g-value-set-flags gvalue (convert-to-foreign value flags-type))))