From: Dmitry Kalyanov <Kalyanov.Dmitry@gmail.com>
Date: Mon, 16 Feb 2009 10:44:34 +0000 (+0300)
Subject: Added object-subclassing (with properties)
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d698b1bf570296ce54a543fdae4233d731f42f72;p=cl-gtk2.git

Added object-subclassing (with properties)
---

diff --git a/glib/glib.asd b/glib/glib.asd
index f10524c..fba497c 100644
--- a/glib/glib.asd
+++ b/glib/glib.asd
@@ -23,5 +23,6 @@
                (:file "gobject.gvalue-parser")
                (:file "gobject.gobject-query")
                (:file "gobject.generating")
-               (:file "gobject.object-defs"))
+               (:file "gobject.object-defs")
+               (:file "gobject.foreign-gobject-subclassing"))
   :depends-on (:cffi :trivial-garbage :metabang-bind :iterate :anaphora :bordeaux-threads :iterate))
\ No newline at end of file
diff --git a/glib/gobject.foreign-gobject-subclassing.lisp b/glib/gobject.foreign-gobject-subclassing.lisp
new file mode 100644
index 0000000..5ec3dc1
--- /dev/null
+++ b/glib/gobject.foreign-gobject-subclassing.lisp
@@ -0,0 +1,141 @@
+(in-package :gobject)
+
+(defvar *registered-types* (make-hash-table :test 'equal))
+
+(defstruct object-type name class parent interfaces properties)
+
+(defvar *lisp-objects-references* (make-hash-table :test 'equal))
+
+(defun object-toggle-pointer (data object is-last-ref)
+  (declare (ignore data))
+  (format t "Toggling pointer on ~a (~A) to being ~A~%" object (gethash (pointer-address object) *lisp-objects-references*) (if is-last-ref "last ref" "not last ref"))
+  (if is-last-ref
+      (remhash (pointer-address object) *lisp-objects-references*)
+      (setf (gethash (pointer-address object) *lisp-objects-references*) (gethash (pointer-address object) *foreign-gobjects*))))
+
+(defun instance-init (instance class)
+  (format t "Initializing instance ~A for type ~A (creating ~A)~%" instance (g-type-name (foreign-slot-value class 'g-type-class 'type)) *current-creating-object*)
+  (setf (gethash (pointer-address instance) *lisp-objects-references*)
+        (or *current-creating-object*
+            (let* ((g-type (foreign-slot-value class 'g-type-class 'type))
+                   (type-name (g-type-name g-type))
+                   (lisp-type-info (gethash type-name *registered-types*))
+                   (lisp-class (object-type-class lisp-type-info)))
+              (make-instance lisp-class :pointer instance))))
+  (g-object-add-toggle-ref instance (callback c-object-toggle-pointer) (null-pointer))
+  (g-object-unref instance))
+
+(defcallback c-object-toggle-pointer :void ((data :pointer) (object :pointer) (is-last-ref :boolean))
+  (object-toggle-pointer data object is-last-ref))
+
+(defcallback c-instance-init :void ((instance :pointer) (class :pointer))
+  (instance-init instance class))
+
+(defcallback c-class-init :void ((class :pointer) (data :pointer))
+  (class-init class data))
+
+(defun minimum-foreign-integer (type &optional (signed t))
+  (if signed
+      (- (ash 1 (1- (* 8 (foreign-type-size type)))))
+      0))
+
+(defun maximum-foreign-integer (type &optional (signed t))
+  (if signed
+      (1- (ash 1 (1- (* 8 (foreign-type-size type)))))
+      (1- (ash 1 (* 8 (foreign-type-size type))))))
+
+(defun property->param-spec (property)
+  (destructuring-bind (property-name property-type property-get-fn property-set-fn) property
+    (let ((property-g-type (ensure-g-type property-type))
+          (flags (append (when property-get-fn (list :readable))
+                         (when property-set-fn (list :writable)))))
+      (ev-case (g-type-fundamental property-g-type)
+        (+g-type-invalid+ (error "GValue is of invalid type ~A (~A)" property-g-type (g-type-name property-g-type)))
+        (+g-type-void+ nil)
+        (+g-type-char+ (g-param-spec-char property-name property-name property-name (minimum-foreign-integer :char) (maximum-foreign-integer :char) 0 flags))
+        (+g-type-uchar+ (g-param-spec-uchar property-name property-name property-name (minimum-foreign-integer :uchar nil) (maximum-foreign-integer :uchar nil) 0 flags))
+        (+g-type-boolean+ (g-param-spec-boolean property-name property-name property-name nil flags))
+        (+g-type-int+ (g-param-spec-int property-name property-name property-name (minimum-foreign-integer :int) (maximum-foreign-integer :int) 0 flags))
+        (+g-type-uint+ (g-param-spec-uint property-name property-name property-name (minimum-foreign-integer :uint nil) (maximum-foreign-integer :uint nil) 0 flags))
+        (+g-type-long+ (g-param-spec-long property-name property-name property-name (minimum-foreign-integer :long) (maximum-foreign-integer :long) 0 flags))
+        (+g-type-ulong+ (g-param-spec-ulong property-name property-name property-name (minimum-foreign-integer :ulong nil) (maximum-foreign-integer :ulong nil) 0 flags))
+        (+g-type-int64+ (g-param-spec-int64 property-name property-name property-name (minimum-foreign-integer :int64) (maximum-foreign-integer :int64) 0 flags))
+        (+g-type-uint64+ (g-param-spec-uint64 property-name property-name property-name (minimum-foreign-integer :uint64 nil) (maximum-foreign-integer :uint64 t) 0 flags))
+        (+g-type-enum+ (g-param-spec-enum property-name property-name property-name property-g-type (enum-item-value (first (get-enum-items property-g-type))) flags))
+        (+g-type-flags+ (g-param-spec-enum property-name property-name property-name property-g-type (flags-item-value (first (get-flags-items property-g-type))) flags))
+        (+g-type-float+ (g-param-spec-float property-name property-name property-name most-negative-single-float most-positive-single-float 0.0 flags))
+        (+g-type-double+ (g-param-spec-double property-name property-name property-name most-negative-double-float most-positive-double-float 0.0d0 flags))
+        (+g-type-string+ (g-param-spec-string property-name property-name property-name "" flags))
+        (+g-type-pointer+ (g-param-spec-pointer property-name property-name property-name flags))
+        (+g-type-boxed+ (g-param-spec-boxed property-name property-name property-name property-g-type flags))
+                                        ;(+g-type-param+ (parse-gvalue-param gvalue))
+        (+g-type-object+ (g-param-spec-object property-name property-name property-name property-g-type flags))
+                                        ;(+g-type-interface+ )
+        (t (error "Unknown type: ~A (~A)" property-g-type (g-type-name property-g-type)))))))
+
+(defun class-init (class data)
+  (declare (ignore data))
+  (format t "class-init for ~A~%" (g-type-name (g-type-from-class class)))
+  (setf (foreign-slot-value class 'g-object-class 'get-property)
+        (callback c-object-property-get)
+        (foreign-slot-value class 'g-object-class 'set-property)
+        (callback c-object-property-set))
+  (let* ((name (g-type-name (foreign-slot-value class 'g-type-class 'type)))
+         (lisp-type-info (gethash name *registered-types*)))
+    (iter (for property in (object-type-properties lisp-type-info))
+          (for param-spec = (property->param-spec property))
+          (for property-id from 123)
+          (format t "installing property ~A~%" property)
+          (g-object-class-install-property class property-id param-spec)))
+  )
+
+(defun object-property-get (object property-id g-value pspec)
+  (declare (ignore property-id))
+  (let* ((lisp-object (gethash (pointer-address object) *lisp-objects-references*))
+         (property-name (foreign-slot-value pspec 'g-param-spec 'name))
+         (property-type (foreign-slot-value pspec 'g-param-spec 'value-type))
+         (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec 'owner-type)))
+         (lisp-type-info (gethash type-name *registered-types*))
+         (property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
+         (property-get-fn (third property-info)))
+    (format t "get(~A,'~A')~%" lisp-object property-name)
+    (let ((value (restart-case
+                     (funcall property-get-fn lisp-object)
+                   (return-from-property-getter (value) :interactive (lambda () (format t "Enter new value: ") (list (eval (read)))) value))))
+      (set-g-value g-value value property-type))))
+
+(defcallback c-object-property-get :void ((object :pointer) (property-id :uint) (value :pointer) (pspec :pointer))
+  (object-property-get object property-id value pspec))
+
+(defun object-property-set (object property-id value pspec)
+  (declare (ignore property-id))
+  (let* ((lisp-object (gethash (pointer-address object) *lisp-objects-references*))
+         (property-name (foreign-slot-value pspec 'g-param-spec 'name))
+         (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec 'owner-type)))
+         (lisp-type-info (gethash type-name *registered-types*))
+         (property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
+         (property-set-fn (fourth property-info))
+         (new-value (parse-gvalue value)))
+    (format t "set(~A,'~A',~A)~%" lisp-object property-name new-value)
+    (restart-case
+        (funcall property-set-fn new-value lisp-object)
+      (return-without-error-from-property-setter () nil))))
+
+(defcallback c-object-property-set :void ((object :pointer) (property-id :uint) (value :pointer) (pspec :pointer))
+  (format t "c-setter")
+  (object-property-set object property-id value pspec))
+
+(defmacro register-object-type-implementation (name class parent interfaces properties)
+  (unless (stringp parent)
+    (setf parent (g-type-name (ensure-g-type parent))))
+  `(progn
+     (setf (gethash ,name *registered-types*) (make-object-type :name ,name :class ',class :parent ,parent :interfaces ,interfaces :properties ,properties))
+     (with-foreign-object (query 'g-type-query)
+       (g-type-query (g-type-from-name ,parent) query)
+       (with-foreign-slots ((class-size instance-size) query g-type-query)
+         (g-type-register-static-simple (g-type-from-name ,parent) ,name class-size (callback c-class-init) instance-size (callback c-instance-init) nil)))
+     (defmethod initialize-instance :before ((object ,class) &key pointer)
+       (unless (or pointer (and (slot-boundp object 'gobject::pointer)
+                                (gobject::pointer object)))
+         (setf (gobject::pointer object) (gobject::g-object-call-constructor ,name nil nil)
+               (gobject::g-object-has-reference object) t)))))
\ No newline at end of file
diff --git a/glib/gobject.foreign-gobject.lisp b/glib/gobject.foreign-gobject.lisp
index 59360df..f462721 100644
--- a/glib/gobject.foreign-gobject.lisp
+++ b/glib/gobject.foreign-gobject.lisp
@@ -13,6 +13,7 @@
 
 (defvar *foreign-gobjects* (make-weak-hash-table :test 'equal :weakness :value))
 (defvar *foreign-gobjects-ref-count* (make-hash-table :test 'equal))
+(defvar *current-creating-object* nil)
 
 (defcstruct g-object-struct
   (type-instance g-type-instance)
@@ -22,6 +23,10 @@
 (defun ref-count (pointer)
   (foreign-slot-value (if (pointerp pointer) pointer (pointer pointer)) 'g-object-struct 'ref-count))
 
+(defmethod initialize-instance :around ((obj g-object) &key)
+  (let ((*current-creating-object* obj))
+    (call-next-method)))
+
 (defmethod initialize-instance :after ((obj g-object) &key &allow-other-keys)
   (unless (slot-boundp obj 'pointer)
     (error "Pointer slot is not initialized for ~A" obj))
@@ -81,7 +86,7 @@
       t))
 
 (defun register-g-object (obj)
-  (debugf "registered GObject ~A with ref-count ~A ~A~%" (pointer obj) (ref-count obj) (if (g-object-is-floating (pointer obj)) "(floating)" ""))
+  (debugf "registered GObject ~A with gobject ref-count ~A ~A~%" (pointer obj) (ref-count obj) (if (g-object-is-floating (pointer obj)) "(floating)" ""))
   (when (should-ref-sink-at-creation obj)
     (debugf "g_object_ref_sink(~A)~%" (pointer obj))
     (g-object-ref-sink (pointer obj)))
diff --git a/glib/gobject.structs.lisp b/glib/gobject.structs.lisp
index 0be2503..6f5014f 100644
--- a/glib/gobject.structs.lisp
+++ b/glib/gobject.structs.lisp
@@ -24,6 +24,12 @@
   (instance-init-fn :pointer)
   (value-table :pointer))
 
+(defcstruct g-type-query
+  (type g-type)
+  (type-name (:string :free-from-foreign nil))
+  (class-size :uint)
+  (instance-size :uint))
+
 (defbitfield g-type-fundamental-flags
   :classed
   :instantiatable
@@ -85,6 +91,7 @@
 
 (defcstruct g-object-class
   (type-class g-type-class)
+  (construct-properties :pointer)
   (constructor :pointer)
   (set-property :pointer)
   (get-property :pointer)
@@ -92,7 +99,8 @@
   (finalize :pointer)
   (dispatch-properties-changed :pointer)
   (notify :pointer)
-  (constructed :pointer))
+  (constructed :pointer)
+  (pdummy :pointer :count 7))
 
 (defbitfield g-param-flags
   :readable
diff --git a/glib/gobject.type.lisp b/glib/gobject.type.lisp
index 0e1fbfb..b8c1638 100644
--- a/glib/gobject.type.lisp
+++ b/glib/gobject.type.lisp
@@ -89,6 +89,15 @@
   (info (:pointer g-type-info))
   (flags g-type-flags))
 
+(defcfun g-type-register-static-simple g-type
+  (parent-type g-type)
+  (type-name :string)
+  (class-size :uint)
+  (class-init :pointer)
+  (instance-size :uint)
+  (instance-init :pointer)
+  (flags g-type-flags))
+
 (defcfun g-type-add-interface-static :void
   (instance-type g-type)
   (interface-type g-type)
@@ -116,4 +125,8 @@
 
 (defcfun g-closure-get-type g-type)
 
-(g-closure-get-type)
\ No newline at end of file
+(g-closure-get-type)
+
+(defcfun g-type-query :void
+  (type g-type)
+  (query (:pointer g-type-query)))
\ No newline at end of file