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   (debugf "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   (debugf "Initializing instance ~A for type ~A (creating ~A)~%" instance (g-type-name (foreign-slot-value class 'g-type-class :type)) *current-creating-object*)
  18   (unless (gethash (pointer-address instance) *lisp-objects-pointers*)
  19     (debugf "  Proceeding with initialization...")
  20     (setf (gethash (pointer-address instance) *lisp-objects-pointers*) t
  21           (gethash (pointer-address instance) *lisp-objects-references*)
  22           (or *current-creating-object*
  23               (let* ((g-type (foreign-slot-value class 'g-type-class :type))
  24                      (type-name (g-type-name g-type))
  25                      (lisp-type-info (gethash type-name *registered-types*))
  26                      (lisp-class (object-type-class lisp-type-info)))
  27                 (make-instance lisp-class :pointer instance))))
  28     (g-object-add-toggle-ref instance (callback c-object-toggle-pointer) (null-pointer))
  29     (g-object-unref instance)))
  30
  31 (defcallback c-object-toggle-pointer :void ((data :pointer) (object :pointer) (is-last-ref :boolean))
  32   (object-toggle-pointer data object is-last-ref))
  33
  34 (defcallback c-instance-init :void ((instance :pointer) (class :pointer))
  35   (instance-init instance class))
  36
  37 (defcallback c-class-init :void ((class :pointer) (data :pointer))
  38   (class-init class data))
  39
  40 (defun minimum-foreign-integer (type &optional (signed t))
  41   (if signed
  42       (- (ash 1 (1- (* 8 (foreign-type-size type)))))
  43       0))
  44
  45 (defun maximum-foreign-integer (type &optional (signed t))
  46   (if signed
  47       (1- (ash 1 (1- (* 8 (foreign-type-size type)))))
  48       (1- (ash 1 (* 8 (foreign-type-size type))))))
  49
  50 (defun property->param-spec (property)
  51   (destructuring-bind (property-name property-type accessor property-get-fn property-set-fn) property
  52     (declare (ignore accessor))
  53     (let ((property-g-type (ensure-g-type property-type))
  54           (flags (append (when property-get-fn (list :readable))
  55                          (when property-set-fn (list :writable)))))
  56       (ev-case (g-type-fundamental property-g-type)
  57         (+g-type-invalid+ (error "GValue is of invalid type ~A (~A)" property-g-type (g-type-name property-g-type)))
  58         (+g-type-void+ nil)
  59         (+g-type-char+ (g-param-spec-char property-name property-name property-name (minimum-foreign-integer :char) (maximum-foreign-integer :char) 0 flags))
  60         (+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))
  61         (+g-type-boolean+ (g-param-spec-boolean property-name property-name property-name nil flags))
  62         (+g-type-int+ (g-param-spec-int property-name property-name property-name (minimum-foreign-integer :int) (maximum-foreign-integer :int) 0 flags))
  63         (+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))
  64         (+g-type-long+ (g-param-spec-long property-name property-name property-name (minimum-foreign-integer :long) (maximum-foreign-integer :long) 0 flags))
  65         (+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))
  66         (+g-type-int64+ (g-param-spec-int64 property-name property-name property-name (minimum-foreign-integer :int64) (maximum-foreign-integer :int64) 0 flags))
  67         (+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))
  68         (+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))
  69         (+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))
  70         (+g-type-float+ (g-param-spec-float property-name property-name property-name most-negative-single-float most-positive-single-float 0.0 flags))
  71         (+g-type-double+ (g-param-spec-double property-name property-name property-name most-negative-double-float most-positive-double-float 0.0d0 flags))
  72         (+g-type-string+ (g-param-spec-string property-name property-name property-name "" flags))
  73         (+g-type-pointer+ (g-param-spec-pointer property-name property-name property-name flags))
  74         (+g-type-boxed+ (g-param-spec-boxed property-name property-name property-name property-g-type flags))
  75                                         ;(+g-type-param+ (parse-g-value-param gvalue))
  76         (+g-type-object+ (g-param-spec-object property-name property-name property-name property-g-type flags))
  77                                         ;(+g-type-interface+ )
  78         (t (error "Unknown type: ~A (~A)" property-g-type (g-type-name property-g-type)))))))
  79
  80 (defun install-properties (class)
  81   (let* ((name (g-type-name (foreign-slot-value class 'g-type-class :type)))
  82          (lisp-type-info (gethash name *registered-types*)))
  83     (iter (for property in (object-type-properties lisp-type-info))
  84           (for param-spec = (property->param-spec property))
  85           (for property-id from 123)
  86           (debugf "installing property ~A~%" property)
  87           (g-object-class-install-property class property-id param-spec))))
  88
  89 (defun vtable-item->cstruct-item (item)
  90   (if (eq :skip (first item))
  91       (rest item)
  92       (list (first item) :pointer)))
  93
  94 (defstruct vtable-method-info name return-type args callback-name)
  95
  96 (defmethod make-load-form ((object vtable-method-info) &optional environment)
  97   (declare (ignore environment))
  98   `(make-vtable-method-info :name ',(vtable-method-info-name object)
  99                             :return-type ',(vtable-method-info-return-type object)
 100                             :args ',(vtable-method-info-args object)
 101                             :callback-name ',(vtable-method-info-callback-name object)))
 102
 103 (defun vtable-methods (items)
 104   (iter (for item in items)
 105         (when (eq :skip (first item)) (next-iteration))
 106         (destructuring-bind (name callback-name return-type &rest args) item
 107           (collect (make-vtable-method-info :name name :return-type return-type :args args :callback-name callback-name)))))
 108
 109 (defvar *vtables* (make-hash-table :test 'equal))
 110
 111 (defstruct vtable-description type-name cstruct-name methods)
 112
 113 (defmacro define-vtable ((type-name cstruct-name) &body items)
 114   `(progn
 115      (defcstruct ,cstruct-name ,@(mapcar #'vtable-item->cstruct-item items))
 116      (setf (gethash ,type-name *vtables*)
 117            (make-vtable-description :type-name ,type-name :cstruct-name ',cstruct-name :methods (list ,@(mapcar #'make-load-form (vtable-methods items)))))
 118      ,@(iter (for method in (vtable-methods items))
 119              (collect `(defgeneric ,(vtable-method-info-name method) (,@(mapcar #'first (vtable-method-info-args method)))))
 120              (collect `(glib-defcallback ,(vtable-method-info-callback-name method) ,(vtable-method-info-return-type method)
 121                            (,@(vtable-method-info-args method))
 122                          (restart-case
 123                              (,(vtable-method-info-name method) ,@(mapcar #'first (vtable-method-info-args method)))
 124                            (return-from-interface-method-implementation (v) :interactive (lambda () (list (eval (read)))) v)))))))
 125
 126 (defun interface-init (iface data)
 127   (destructuring-bind (class-name interface-name) (prog1 (get-stable-pointer-value data) (free-stable-pointer data))
 128     (declare (ignorable class-name))
 129     (let* ((vtable (gethash interface-name *vtables*))
 130            (vtable-cstruct (vtable-description-cstruct-name vtable)))
 131       (debugf "interface-init for class ~A and interface ~A~%" class-name interface-name)
 132       (iter (for method in (vtable-description-methods vtable))
 133             (setf (foreign-slot-value iface vtable-cstruct (vtable-method-info-name method)) (get-callback (vtable-method-info-callback-name method)))))))
 134
 135 (defcallback c-interface-init :void ((iface :pointer) (data :pointer))
 136   (interface-init iface data))
 137
 138 (defun add-interface (name interface)
 139   (let* ((interface-info (list name interface))
 140          (interface-info-ptr (allocate-stable-pointer interface-info)))
 141     (with-foreign-object (info 'g-interface-info)
 142       (setf (foreign-slot-value info 'g-interface-info :interface-init) (callback c-interface-init)
 143             (foreign-slot-value info 'g-interface-info :interface-data) interface-info-ptr)
 144       (g-type-add-interface-static (g-type-from-name name) (ensure-g-type interface) info))))
 145
 146 (defun add-interfaces (name)
 147   (let* ((lisp-type-info (gethash name *registered-types*))
 148          (interfaces (object-type-interfaces lisp-type-info)))
 149     (iter (for interface in interfaces)
 150           (add-interface name interface))))
 151
 152 (defun class-init (class data)
 153   (declare (ignore data))
 154   (debugf "class-init for ~A~%" (g-type-name (g-type-from-class class)))
 155   (setf (foreign-slot-value class 'g-object-class :get-property)
 156         (callback c-object-property-get)
 157         (foreign-slot-value class 'g-object-class :set-property)
 158         (callback c-object-property-set))
 159
 160   (install-properties class))
 161
 162 (defun object-property-get (object property-id g-value pspec)
 163   (declare (ignore property-id))
 164   (let* ((lisp-object (gethash (pointer-address object) *lisp-objects-references*))
 165          (property-name (foreign-slot-value pspec 'g-param-spec :name))
 166          (property-type (foreign-slot-value pspec 'g-param-spec :value-type))
 167          (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec :owner-type)))
 168          (lisp-type-info (gethash type-name *registered-types*))
 169          (property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
 170          (property-get-fn (fourth property-info)))
 171     (debugf "get(~A,'~A')~%" lisp-object property-name)
 172     (let ((value (restart-case
 173                      (funcall property-get-fn lisp-object)
 174                    (return-from-property-getter (value) :interactive (lambda () (debugf "Enter new value: ") (list (eval (read)))) value))))
 175       (set-g-value g-value value property-type))))
 176
 177 (defcallback c-object-property-get :void ((object :pointer) (property-id :uint) (value :pointer) (pspec :pointer))
 178   (object-property-get object property-id value pspec))
 179
 180 (defun object-property-set (object property-id value pspec)
 181   (declare (ignore property-id))
 182   (let* ((lisp-object (gethash (pointer-address object) *lisp-objects-references*))
 183          (property-name (foreign-slot-value pspec 'g-param-spec :name))
 184          (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec :owner-type)))
 185          (lisp-type-info (gethash type-name *registered-types*))
 186          (property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
 187          (property-set-fn (fifth property-info))
 188          (new-value (parse-g-value value)))
 189     (debugf "set(~A,'~A',~A)~%" lisp-object property-name new-value)
 190     (restart-case
 191         (funcall property-set-fn new-value lisp-object)
 192       (return-without-error-from-property-setter () nil))))
 193
 194 (defcallback c-object-property-set :void ((object :pointer) (property-id :uint) (value :pointer) (pspec :pointer))
 195   (object-property-set object property-id value pspec))
 196
 197 (defmacro register-object-type-implementation (name class parent interfaces properties)
 198   (unless (stringp parent)
 199     (setf parent (g-type-name (ensure-g-type parent))))
 200   `(progn
 201      (setf (gethash ,name *registered-types*) (make-object-type :name ,name :class ',class :parent ,parent :interfaces ',interfaces :properties ',properties))
 202      (at-init (',class)
 203        (debugf "Registering GObject type implementation ~A for type ~A~%" ',class ,name)
 204        (with-foreign-object (query 'g-type-query)
 205          (g-type-query (g-type-from-name ,parent) query)
 206          (g-type-register-static-simple (g-type-from-name ,parent)
 207                                         ,name
 208                                         (foreign-slot-value query 'g-type-query :class-size)
 209                                         (callback c-class-init)
 210                                         (foreign-slot-value query 'g-type-query :instance-size)
 211                                         (callback c-instance-init) nil))
 212        (add-interfaces ,name))
 213      (defmethod initialize-instance :before ((object ,class) &key pointer)
 214        (unless (or pointer (and (slot-boundp object 'gobject::pointer)
 215                                 (gobject::pointer object)))
 216          (setf (gobject::pointer object) (gobject::g-object-call-constructor ,name nil nil)
 217                (gobject::g-object-has-reference object) t)))
 218      (progn
 219        ,@(iter (for (prop-name prop-type prop-accessor prop-reader prop-writer) in properties)
 220                (when prop-reader
 221                  (collect `(defun ,prop-accessor (object) (g-object-call-get-property object ,prop-name))))
 222                (when prop-writer
 223                  (collect `(defun (setf ,prop-accessor) (new-value object) (g-object-call-set-property object ,prop-name new-value))))))
 224      ,name))