glib/gobject.gvalue-parser.lisp

   1 (in-package :gobject)
   2
   3 (defun gvalue-type (gvalue)
   4   (foreign-slot-value gvalue 'g-value 'type))
   5
   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))
  10        (cond
  11          ,@(loop
  12               for (key . forms) in clauses
  13               collect
  14                 (if (eq key t)
  15                     `(t ,@forms)
  16                     `((equalp ,key ,value) ,@forms)))))))
  17
  18 (defun parse-gvalue (gvalue)
  19   (let* ((type (gvalue-type gvalue))
  20          (fundamental-type (g-type-fundamental type)))
  21     (cond
  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)))
  25            (+g-type-void+ nil)
  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))))))))
  46
  47 (defun set-g-value (gvalue value type &key zero-g-value)
  48   (if zero-g-value
  49     (g-value-zero gvalue)
  50     (g-value-unset gvalue))
  51   (g-value-init gvalue type)
  52   (let ((fundamental-type (g-type-fundamental type)))
  53     (cond
  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))
  57            (+g-type-void+ nil)
  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))))))))
  78
  79 ;;Enums
  80
  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*))
  86
  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)))
  91     (unless enum-type
  92       (error "Enum ~A is not registered" type-name))
  93     (convert-from-foreign (g-value-get-enum gvalue) enum-type)))
  94
  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)))
  99     (unless enum-type
 100       (error "Enum ~A is not registered" type-name))
 101     (g-value-set-enum gvalue (convert-to-foreign value enum-type))))
 102
 103
 104 ;;Flags
 105
 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*))
 111
 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)))
 116     (unless flags-type
 117       (error "Flags ~A is not registered" type-name))
 118     (convert-from-foreign (g-value-get-flags gvalue) flags-type)))
 119
 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)))
 124     (unless flags-type
 125       (error "Flags ~A is not registered" type-name))
 126     (g-value-set-flags gvalue (convert-to-foreign value flags-type))))
 127
 128 ;;Objects
 129
 130 (defun parse-gvalue-object (gvalue)
 131   (get-g-object-for-pointer (g-value-get-object gvalue)))
 132
 133 (defun set-gvalue-object (gvalue value)
 134   (g-value-set-object gvalue (if value (pointer value) (null-pointer))))