From: Dmitry Kalyanov Date: Sun, 12 Jul 2009 10:28:11 +0000 (+0400) Subject: Moved GValue parsing code to gobject.gvalue.lisp X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=8d777e3bbd4bfe1567af0fbd31316cf08d830b86;p=cl-gtk2.git Moved GValue parsing code to gobject.gvalue.lisp --- diff --git a/glib/cl-gtk2-glib.asd b/glib/cl-gtk2-glib.asd index 810050d..af886e3 100644 --- a/glib/cl-gtk2-glib.asd +++ b/glib/cl-gtk2-glib.asd @@ -26,7 +26,6 @@ (:file "gobject.foreign-gobject") (:file "gobject.foreign-closures") (:file "gobject.foreign-gboxed") - (:file "gobject.gvalue-parser") (:file "gobject.meta") (:file "gobject.generating") (:file "gobject.object-defs") diff --git a/glib/gobject.gvalue-parser.lisp b/glib/gobject.gvalue-parser.lisp index fc4767d..ea87d55 100644 --- a/glib/gobject.gvalue-parser.lisp +++ b/glib/gobject.gvalue-parser.lisp @@ -1,147 +1,2 @@ (in-package :gobject) -(defun gvalue-type (gvalue) - (foreign-slot-value gvalue 'g-value :type)) - -(defmacro ev-case (keyform &body clauses) - "Macro that is an analogue of CASE except that it evaluates keyforms" - (let ((value (gensym))) - `(let ((,value ,keyform)) - (cond - ,@(loop - for (key . forms) in clauses - collect - (if (eq key t) - `(t ,@forms) - `((equalp ,key ,value) ,@forms))))))) - -(defun parse-gvalue (gvalue) - "Parses the GValue structure and returns the corresponding Lisp object. - -@arg[value]{a C pointer to the GValue structure} -@return{value contained in the GValue structure. Type of value depends on GValue type}" - (let* ((type (ensure-g-type (gvalue-type gvalue))) - (fundamental-type (ensure-g-type (g-type-fundamental type)))) - (cond - ((= type (ensure-g-type (g-strv-get-type))) (convert-from-foreign (g-value-get-boxed gvalue) '(glib:gstrv :free-from-foreign nil))) - (t (ev-case fundamental-type - (+g-type-invalid+ (error "GValue is of invalid type (~A)" (g-type-name type))) - (+g-type-void+ nil) - (+g-type-char+ (g-value-get-char gvalue)) - (+g-type-uchar+ (g-value-get-uchar gvalue)) - (+g-type-boolean+ (g-value-get-boolean gvalue)) - (+g-type-int+ (g-value-get-int gvalue)) - (+g-type-uint+ (g-value-get-uint gvalue)) - (+g-type-long+ (g-value-get-long gvalue)) - (+g-type-ulong+ (g-value-get-ulong gvalue)) - (+g-type-int64+ (g-value-get-int64 gvalue)) - (+g-type-uint64+ (g-value-get-uint64 gvalue)) - (+g-type-enum+ (parse-gvalue-enum gvalue)) - (+g-type-flags+ (parse-gvalue-flags gvalue)) - (+g-type-float+ (g-value-get-float gvalue)) - (+g-type-double+ (g-value-get-double gvalue)) - (+g-type-string+ (g-value-get-string gvalue)) - (+g-type-pointer+ (g-value-get-pointer gvalue)) - (+g-type-boxed+ (parse-gvalue-boxed gvalue)) - (+g-type-param+ (parse-g-param-spec (g-value-get-param gvalue))) - (+g-type-object+ (parse-gvalue-object gvalue)) - (+g-type-interface+ (parse-gvalue-object gvalue)) - (t (error "Unknown type: ~A (~A)" type (g-type-name type)))))))) - -(defun set-g-value (gvalue value type &key zero-g-value unset-g-value (g-value-init t)) - "Assigns the GValue structure @code{gvalue} the value @code{value} of GType @code{type}. - -@arg[gvalue]{a C pointer to the GValue structure} -@arg[value]{a Lisp object that is to be assigned} -@arg[type]{a GType that is to be assigned} -@arg[zero-g-value]{a boolean specifying whether GValue should be zero-initialized before assigning. See @fun{g-value-zero}} -@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} -@arg[g-value-init]{a boolean specifying where GValue should be initialized}" - (setf type (ensure-g-type type)) - (cond - (zero-g-value (g-value-zero gvalue)) - (unset-g-value (g-value-unset gvalue))) - (when g-value-init (g-value-init gvalue type)) - (let ((fundamental-type (ensure-g-type (g-type-fundamental type)))) - (cond - ((= type (ensure-g-type (g-strv-get-type))) (g-value-set-boxed gvalue (convert-to-foreign value 'glib:gstrv))) - (t (ev-case fundamental-type - (+g-type-invalid+ (error "Invalid type (~A)" type)) - (+g-type-void+ nil) - (+g-type-char+ (g-value-set-char gvalue value)) - (+g-type-uchar+ (g-value-set-uchar gvalue value)) - (+g-type-boolean+ (g-value-set-boolean gvalue value)) - (+g-type-int+ (g-value-set-int gvalue value)) - (+g-type-uint+ (g-value-set-uint gvalue value)) - (+g-type-long+ (g-value-set-long gvalue value)) - (+g-type-ulong+ (g-value-set-ulong gvalue value)) - (+g-type-int64+ (g-value-set-int64 gvalue value)) - (+g-type-uint64+ (g-value-set-uint64 gvalue value)) - (+g-type-enum+ (set-gvalue-enum gvalue value)) - (+g-type-flags+ (set-gvalue-flags gvalue value)) - (+g-type-float+ (unless (realp value) (error "~A is not a real number" value)) (g-value-set-float gvalue (coerce value 'single-float))) - (+g-type-double+ (unless (realp value) (error "~A is not a real number" value)) (g-value-set-double gvalue (coerce value 'double-float))) - (+g-type-string+ (g-value-set-string gvalue value)) - (+g-type-pointer+ (g-value-set-pointer gvalue value)) - (+g-type-boxed+ (set-gvalue-boxed gvalue value)) - ;(+g-type-param+ (set-gvalue-param gvalue value)) - (+g-type-object+ (set-gvalue-object gvalue value)) - (+g-type-interface+ (set-gvalue-object gvalue value)) - (t (error "Unknown type: ~A (~A)" type (g-type-name type)))))))) - -;;Enums - -(defvar *registered-enum-types* (make-hash-table :test 'equal)) -(defun register-enum-type (name type) - (setf (gethash name *registered-enum-types*) type)) -(defun registered-enum-type (name) - (gethash name *registered-enum-types*)) - -(defun parse-gvalue-enum (gvalue) - (let* ((g-type (gvalue-type gvalue)) - (type-name (g-type-name g-type)) - (enum-type (registered-enum-type type-name))) - (unless enum-type - (error "Enum ~A is not registered" type-name)) - (convert-from-foreign (g-value-get-enum gvalue) enum-type))) - -(defun set-gvalue-enum (gvalue value) - (let* ((g-type (gvalue-type gvalue)) - (type-name (g-type-name g-type)) - (enum-type (registered-enum-type type-name))) - (unless enum-type - (error "Enum ~A is not registered" type-name)) - (g-value-set-enum gvalue (convert-to-foreign value enum-type)))) - - -;;Flags - -(defvar *registered-flags-types* (make-hash-table :test 'equal)) -(defun register-flags-type (name type) - (setf (gethash name *registered-flags-types*) type)) -(defun registered-flags-type (name) - (gethash name *registered-flags-types*)) - -(defun parse-gvalue-flags (gvalue) - (let* ((g-type (gvalue-type gvalue)) - (type-name (g-type-name g-type)) - (flags-type (registered-flags-type type-name))) - (unless flags-type - (error "Flags ~A is not registered" type-name)) - (convert-from-foreign (g-value-get-flags gvalue) flags-type))) - -(defun set-gvalue-flags (gvalue value) - (let* ((g-type (gvalue-type gvalue)) - (type-name (g-type-name g-type)) - (flags-type (registered-flags-type type-name))) - (unless flags-type - (error "Flags ~A is not registered" type-name)) - (g-value-set-flags gvalue (convert-to-foreign value flags-type)))) - -;;Objects - -(defun parse-gvalue-object (gvalue) - (get-g-object-for-pointer (g-value-get-object gvalue))) - -(defun set-gvalue-object (gvalue value) - (g-value-set-object gvalue (if value (pointer value) (null-pointer)))) diff --git a/glib/gobject.gvalue.lisp b/glib/gobject.gvalue.lisp index ed67c9b..a571efc 100644 --- a/glib/gobject.gvalue.lisp +++ b/glib/gobject.gvalue.lisp @@ -8,3 +8,148 @@ for i from 0 below (foreign-type-size 'g-value) do (setf (mem-ref g-value :uchar i) 0))) +(defun gvalue-type (gvalue) + (foreign-slot-value gvalue 'g-value :type)) + +(defmacro ev-case (keyform &body clauses) + "Macro that is an analogue of CASE except that it evaluates keyforms" + (let ((value (gensym))) + `(let ((,value ,keyform)) + (cond + ,@(loop + for (key . forms) in clauses + collect + (if (eq key t) + `(t ,@forms) + `((equalp ,key ,value) ,@forms))))))) + +(defun parse-gvalue (gvalue) + "Parses the GValue structure and returns the corresponding Lisp object. + +@arg[value]{a C pointer to the GValue structure} +@return{value contained in the GValue structure. Type of value depends on GValue type}" + (let* ((type (ensure-g-type (gvalue-type gvalue))) + (fundamental-type (ensure-g-type (g-type-fundamental type)))) + (cond + ((= type (ensure-g-type (g-strv-get-type))) (convert-from-foreign (g-value-get-boxed gvalue) '(glib:gstrv :free-from-foreign nil))) + (t (ev-case fundamental-type + (+g-type-invalid+ (error "GValue is of invalid type (~A)" (g-type-name type))) + (+g-type-void+ nil) + (+g-type-char+ (g-value-get-char gvalue)) + (+g-type-uchar+ (g-value-get-uchar gvalue)) + (+g-type-boolean+ (g-value-get-boolean gvalue)) + (+g-type-int+ (g-value-get-int gvalue)) + (+g-type-uint+ (g-value-get-uint gvalue)) + (+g-type-long+ (g-value-get-long gvalue)) + (+g-type-ulong+ (g-value-get-ulong gvalue)) + (+g-type-int64+ (g-value-get-int64 gvalue)) + (+g-type-uint64+ (g-value-get-uint64 gvalue)) + (+g-type-enum+ (parse-gvalue-enum gvalue)) + (+g-type-flags+ (parse-gvalue-flags gvalue)) + (+g-type-float+ (g-value-get-float gvalue)) + (+g-type-double+ (g-value-get-double gvalue)) + (+g-type-string+ (g-value-get-string gvalue)) + (+g-type-pointer+ (g-value-get-pointer gvalue)) + (+g-type-boxed+ (parse-gvalue-boxed gvalue)) + (+g-type-param+ (parse-g-param-spec (g-value-get-param gvalue))) + (+g-type-object+ (parse-gvalue-object gvalue)) + (+g-type-interface+ (parse-gvalue-object gvalue)) + (t (error "Unknown type: ~A (~A)" type (g-type-name type)))))))) + +(defun set-g-value (gvalue value type &key zero-g-value unset-g-value (g-value-init t)) + "Assigns the GValue structure @code{gvalue} the value @code{value} of GType @code{type}. + +@arg[gvalue]{a C pointer to the GValue structure} +@arg[value]{a Lisp object that is to be assigned} +@arg[type]{a GType that is to be assigned} +@arg[zero-g-value]{a boolean specifying whether GValue should be zero-initialized before assigning. See @fun{g-value-zero}} +@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} +@arg[g-value-init]{a boolean specifying where GValue should be initialized}" + (setf type (ensure-g-type type)) + (cond + (zero-g-value (g-value-zero gvalue)) + (unset-g-value (g-value-unset gvalue))) + (when g-value-init (g-value-init gvalue type)) + (let ((fundamental-type (ensure-g-type (g-type-fundamental type)))) + (cond + ((= type (ensure-g-type (g-strv-get-type))) (g-value-set-boxed gvalue (convert-to-foreign value 'glib:gstrv))) + (t (ev-case fundamental-type + (+g-type-invalid+ (error "Invalid type (~A)" type)) + (+g-type-void+ nil) + (+g-type-char+ (g-value-set-char gvalue value)) + (+g-type-uchar+ (g-value-set-uchar gvalue value)) + (+g-type-boolean+ (g-value-set-boolean gvalue value)) + (+g-type-int+ (g-value-set-int gvalue value)) + (+g-type-uint+ (g-value-set-uint gvalue value)) + (+g-type-long+ (g-value-set-long gvalue value)) + (+g-type-ulong+ (g-value-set-ulong gvalue value)) + (+g-type-int64+ (g-value-set-int64 gvalue value)) + (+g-type-uint64+ (g-value-set-uint64 gvalue value)) + (+g-type-enum+ (set-gvalue-enum gvalue value)) + (+g-type-flags+ (set-gvalue-flags gvalue value)) + (+g-type-float+ (unless (realp value) (error "~A is not a real number" value)) (g-value-set-float gvalue (coerce value 'single-float))) + (+g-type-double+ (unless (realp value) (error "~A is not a real number" value)) (g-value-set-double gvalue (coerce value 'double-float))) + (+g-type-string+ (g-value-set-string gvalue value)) + (+g-type-pointer+ (g-value-set-pointer gvalue value)) + (+g-type-boxed+ (set-gvalue-boxed gvalue value)) + ;(+g-type-param+ (set-gvalue-param gvalue value)) + (+g-type-object+ (set-gvalue-object gvalue value)) + (+g-type-interface+ (set-gvalue-object gvalue value)) + (t (error "Unknown type: ~A (~A)" type (g-type-name type)))))))) + +;;Enums + +(defvar *registered-enum-types* (make-hash-table :test 'equal)) +(defun register-enum-type (name type) + (setf (gethash name *registered-enum-types*) type)) +(defun registered-enum-type (name) + (gethash name *registered-enum-types*)) + +(defun parse-gvalue-enum (gvalue) + (let* ((g-type (gvalue-type gvalue)) + (type-name (g-type-name g-type)) + (enum-type (registered-enum-type type-name))) + (unless enum-type + (error "Enum ~A is not registered" type-name)) + (convert-from-foreign (g-value-get-enum gvalue) enum-type))) + +(defun set-gvalue-enum (gvalue value) + (let* ((g-type (gvalue-type gvalue)) + (type-name (g-type-name g-type)) + (enum-type (registered-enum-type type-name))) + (unless enum-type + (error "Enum ~A is not registered" type-name)) + (g-value-set-enum gvalue (convert-to-foreign value enum-type)))) + + +;;Flags + +(defvar *registered-flags-types* (make-hash-table :test 'equal)) +(defun register-flags-type (name type) + (setf (gethash name *registered-flags-types*) type)) +(defun registered-flags-type (name) + (gethash name *registered-flags-types*)) + +(defun parse-gvalue-flags (gvalue) + (let* ((g-type (gvalue-type gvalue)) + (type-name (g-type-name g-type)) + (flags-type (registered-flags-type type-name))) + (unless flags-type + (error "Flags ~A is not registered" type-name)) + (convert-from-foreign (g-value-get-flags gvalue) flags-type))) + +(defun set-gvalue-flags (gvalue value) + (let* ((g-type (gvalue-type gvalue)) + (type-name (g-type-name g-type)) + (flags-type (registered-flags-type type-name))) + (unless flags-type + (error "Flags ~A is not registered" type-name)) + (g-value-set-flags gvalue (convert-to-foreign value flags-type)))) + +;;Objects + +(defun parse-gvalue-object (gvalue) + (get-g-object-for-pointer (g-value-get-object gvalue))) + +(defun set-gvalue-object (gvalue value) + (g-value-set-object gvalue (if value (pointer value) (null-pointer))))