glib/gobject.foreign-gobject-subclassing.lisp

   1 (in-package :gobject)
   2
   3 (defvar *registered-types* (make-hash-table :test 'equal))
   4
   5 (defstruct object-type name class parent interfaces properties)
   6
   7 (defvar *lisp-objects-references* (make-hash-table :test 'equal))
   8
   9 (defun object-toggle-pointer (data object is-last-ref)
  10   (declare (ignore data))
  11   (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"))
  12   (if is-last-ref
  13       (remhash (pointer-address object) *lisp-objects-references*)
  14       (setf (gethash (pointer-address object) *lisp-objects-references*) (gethash (pointer-address object) *foreign-gobjects*))))
  15
  16 (defun instance-init (instance class)
  17   (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*)
  18   (setf (gethash (pointer-address instance) *lisp-objects-references*)
  19         (or *current-creating-object*
  20             (let* ((g-type (foreign-slot-value class 'g-type-class 'type))
  21                    (type-name (g-type-name g-type))
  22                    (lisp-type-info (gethash type-name *registered-types*))
  23                    (lisp-class (object-type-class lisp-type-info)))
  24               (make-instance lisp-class :pointer instance))))
  25   (g-object-add-toggle-ref instance (callback c-object-toggle-pointer) (null-pointer))
  26   (g-object-unref instance))
  27
  28 (defcallback c-object-toggle-pointer :void ((data :pointer) (object :pointer) (is-last-ref :boolean))
  29   (object-toggle-pointer data object is-last-ref))
  30
  31 (defcallback c-instance-init :void ((instance :pointer) (class :pointer))
  32   (instance-init instance class))
  33
  34 (defcallback c-class-init :void ((class :pointer) (data :pointer))
  35   (class-init class data))
  36
  37 (defun minimum-foreign-integer (type &optional (signed t))
  38   (if signed
  39       (- (ash 1 (1- (* 8 (foreign-type-size type)))))
  40       0))
  41
  42 (defun maximum-foreign-integer (type &optional (signed t))
  43   (if signed
  44       (1- (ash 1 (1- (* 8 (foreign-type-size type)))))
  45       (1- (ash 1 (* 8 (foreign-type-size type))))))
  46
  47 (defun property->param-spec (property)
  48   (destructuring-bind (property-name property-type property-get-fn property-set-fn) property
  49     (let ((property-g-type (ensure-g-type property-type))
  50           (flags (append (when property-get-fn (list :readable))
  51                          (when property-set-fn (list :writable)))))
  52       (ev-case (g-type-fundamental property-g-type)
  53         (+g-type-invalid+ (error "GValue is of invalid type ~A (~A)" property-g-type (g-type-name property-g-type)))
  54         (+g-type-void+ nil)
  55         (+g-type-char+ (g-param-spec-char property-name property-name property-name (minimum-foreign-integer :char) (maximum-foreign-integer :char) 0 flags))
  56         (+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))
  57         (+g-type-boolean+ (g-param-spec-boolean property-name property-name property-name nil flags))
  58         (+g-type-int+ (g-param-spec-int property-name property-name property-name (minimum-foreign-integer :int) (maximum-foreign-integer :int) 0 flags))
  59         (+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))
  60         (+g-type-long+ (g-param-spec-long property-name property-name property-name (minimum-foreign-integer :long) (maximum-foreign-integer :long) 0 flags))
  61         (+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))
  62         (+g-type-int64+ (g-param-spec-int64 property-name property-name property-name (minimum-foreign-integer :int64) (maximum-foreign-integer :int64) 0 flags))
  63         (+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))
  64         (+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))
  65         (+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))
  66         (+g-type-float+ (g-param-spec-float property-name property-name property-name most-negative-single-float most-positive-single-float 0.0 flags))
  67         (+g-type-double+ (g-param-spec-double property-name property-name property-name most-negative-double-float most-positive-double-float 0.0d0 flags))
  68         (+g-type-string+ (g-param-spec-string property-name property-name property-name "" flags))
  69         (+g-type-pointer+ (g-param-spec-pointer property-name property-name property-name flags))
  70         (+g-type-boxed+ (g-param-spec-boxed property-name property-name property-name property-g-type flags))
  71                                         ;(+g-type-param+ (parse-gvalue-param gvalue))
  72         (+g-type-object+ (g-param-spec-object property-name property-name property-name property-g-type flags))
  73                                         ;(+g-type-interface+ )
  74         (t (error "Unknown type: ~A (~A)" property-g-type (g-type-name property-g-type)))))))
  75
  76 (defun class-init (class data)
  77   (declare (ignore data))
  78   (format t "class-init for ~A~%" (g-type-name (g-type-from-class class)))
  79   (setf (foreign-slot-value class 'g-object-class 'get-property)
  80         (callback c-object-property-get)
  81         (foreign-slot-value class 'g-object-class 'set-property)
  82         (callback c-object-property-set))
  83   (let* ((name (g-type-name (foreign-slot-value class 'g-type-class 'type)))
  84          (lisp-type-info (gethash name *registered-types*)))
  85     (iter (for property in (object-type-properties lisp-type-info))
  86           (for param-spec = (property->param-spec property))
  87           (for property-id from 123)
  88           (format t "installing property ~A~%" property)
  89           (g-object-class-install-property class property-id param-spec)))
  90   )
  91
  92 (defun object-property-get (object property-id g-value pspec)
  93   (declare (ignore property-id))
  94   (let* ((lisp-object (gethash (pointer-address object) *lisp-objects-references*))
  95          (property-name (foreign-slot-value pspec 'g-param-spec 'name))
  96          (property-type (foreign-slot-value pspec 'g-param-spec 'value-type))
  97          (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec 'owner-type)))
  98          (lisp-type-info (gethash type-name *registered-types*))
  99          (property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
 100          (property-get-fn (third property-info)))
 101     (format t "get(~A,'~A')~%" lisp-object property-name)
 102     (let ((value (restart-case
 103                      (funcall property-get-fn lisp-object)
 104                    (return-from-property-getter (value) :interactive (lambda () (format t "Enter new value: ") (list (eval (read)))) value))))
 105       (set-g-value g-value value property-type))))
 106
 107 (defcallback c-object-property-get :void ((object :pointer) (property-id :uint) (value :pointer) (pspec :pointer))
 108   (object-property-get object property-id value pspec))
 109
 110 (defun object-property-set (object property-id value pspec)
 111   (declare (ignore property-id))
 112   (let* ((lisp-object (gethash (pointer-address object) *lisp-objects-references*))
 113          (property-name (foreign-slot-value pspec 'g-param-spec 'name))
 114          (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec 'owner-type)))
 115          (lisp-type-info (gethash type-name *registered-types*))
 116          (property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
 117          (property-set-fn (fourth property-info))
 118          (new-value (parse-gvalue value)))
 119     (format t "set(~A,'~A',~A)~%" lisp-object property-name new-value)
 120     (restart-case
 121         (funcall property-set-fn new-value lisp-object)
 122       (return-without-error-from-property-setter () nil))))
 123
 124 (defcallback c-object-property-set :void ((object :pointer) (property-id :uint) (value :pointer) (pspec :pointer))
 125   (format t "c-setter")
 126   (object-property-set object property-id value pspec))
 127
 128 (defmacro register-object-type-implementation (name class parent interfaces properties)
 129   (unless (stringp parent)
 130     (setf parent (g-type-name (ensure-g-type parent))))
 131   `(progn
 132      (setf (gethash ,name *registered-types*) (make-object-type :name ,name :class ',class :parent ,parent :interfaces ,interfaces :properties ,properties))
 133      (with-foreign-object (query 'g-type-query)
 134        (g-type-query (g-type-from-name ,parent) query)
 135        (with-foreign-slots ((class-size instance-size) query g-type-query)
 136          (g-type-register-static-simple (g-type-from-name ,parent) ,name class-size (callback c-class-init) instance-size (callback c-instance-init) nil)))
 137      (defmethod initialize-instance :before ((object ,class) &key pointer)
 138        (unless (or pointer (and (slot-boundp object 'gobject::pointer)
 139                                 (gobject::pointer object)))
 140          (setf (gobject::pointer object) (gobject::g-object-call-constructor ,name nil nil)
 141                (gobject::g-object-has-reference object) t)))))