Sun May 31 19:33:32 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Rework QObject parent ownership transfer

--- old-qt.gui/src/object.lisp 2014-10-30 07:48:34.000000000 +0100

+++ new-qt.gui/src/object.lisp 2014-10-30 07:48:34.000000000 +0100

@@ -1,17 +1,16 @@

(in-package :qt)

-(declaim (optimize (debug 3)))

(let ((object (make-instance 'object)))

(defmethod cxx:static-meta-object ((class (eql (find-class 'object))))

"No OBJECT.STATIC-META-OBJECT (r558420)."

(cxx:meta-object object))

- (defmethod cxx:static-meta-object ((class smoke::smoke-wrapper-class))

+ (defmethod cxx:static-meta-object ((class cxx:class))

(cxx:static-meta-object (smoke::find-smoke-class class))))

-(defmethod documentation :around ((class smoke::smoke-standard-class)

+(defmethod documentation :around ((class cxx:class)

(doc-type t))

(if (and (subtypep class (find-class 'object))

- (not (subtypep class (find-class 'smoke::smoke-wrapper-class))))

+ (not (subtypep class (find-class 'cxx:class))))

(format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}

Signals:

@@ -56,10 +55,6 @@

(meta-object-slots (cxx:static-meta-object class)))

-(defvar *children* (make-hash-table)

- "A list of custom subclasses of QObject which have a parent

-and therefor must not be garbage collected.")

-

(defmethod initialize-instance :after ((object object)

&key pointer &allow-other-keys)

"Registers the object to the parent when a parent was set in the constructor

@@ -69,16 +64,16 @@

(error "Object ~A has not been constructed" object))

(when (and (null pointer)

(not (null-pointer-p (smoke::pointer object)))

-; (typep (class-of object) 'smoke::smoke-wrapper-class)

+; (typep (class-of object) 'cxx:class)

(not (null-pointer-p (smoke::pointer (cxx:parent object)))))

- (setf (gethash (smoke::pointer object) *children*) object)))

+ (smoke::disown-object object)))

(define-condition wrapper-gc (storage-condition)

((class-name :initarg :class-name

:documentation "The class name of the gc'ed object.")

(pointer :initarg :pointer))

(:report (lambda (condition stream)

- (format stream "The object ~A ~A of type smoke-wrapper-class

+ (format stream "The object ~A ~A of type cxx:class

has a parent but got garbage collected."

(slot-value condition 'class-name)

(slot-value condition 'pointer)))))

@@ -97,33 +92,34 @@

"QObject")

"deleteLater")))

- (defmethod smoke::make-finalize ((object object))

+(defun print-object-to-string (object)

+ (with-output-to-string (stream)

+ (print-object object stream)))

+

+(defmethod smoke::make-finalize ((object object))

"Delete the qt:object OBJECT,

by calling cxx:delete-later iff it has no parent."

(let ((pointer (pointer object))

- (name (class-name (class-of object)))

+ (class (class-of object))

(next (call-next-method)))

- (if (typep (class-of object) 'smoke::smoke-wrapper-class)

+ (if (typep (class-of object) 'cxx:class)

#'(lambda ()

(handler-case

(if (null-pointer-p (smoke::pointer-call *get-parent* pointer))

(smoke::pointer-call *delete-later* pointer)

(error (make-condition 'wrapper-gc :class-name name

:pointer pointer)))

- (condition (condition)

- (format *debug-io* "error: wrap finalize ~A ~A~%" name

- condition))))

+ (error (condition)

+ (smoke::report-finalize-error condition "qt:object wrap"

+ (name class) pointer))))

#'(lambda ()

(handler-case

- (progn

- (when (null-pointer-p (smoke::pointer-call *get-parent* pointer))

- (funcall next)))

- (condition (condition)

- (format *debug-io* "error: qfinalize ~A ~A ~A~%" name

- pointer

- condition))))))

- ;(smoke::pointer-call delete-later pointer)))))))

- )

+ (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))

+ (funcall next)

+ (cerror 'continue "Finalizer for object with a parent called."))

+ (error (condition)

+ (smoke::report-finalize-error condition "qt:object"

+ (name class) pointer)))))))

;;;

;;; The event-notify callback get called by QCoreApplication,

@@ -143,27 +139,22 @@

(cffi:defcallback event-notify smoke:cxx-bool

((data :pointer))

(declare (optimize (speed 3)))

- (let ((event (make-instance 'event :pointer (cffi:mem-aref data :pointer 1)

- :owned-p nil)))

+ (let ((event (make-instance 'event :pointer (cffi:mem-aref data :pointer 1))))

(enum-case (cxx:type event)

(event.+child-added+

(let* ((child-event (make-instance 'child-event

:pointer

- (smoke::upcast event (find-class 'child-event))

- :owned-p nil))

- (child (smoke::get-object

- (smoke::pointer (cxx:child child-event)))))

-; (when (and child

-; (typep (class-of child)

-; 'smoke::smoke-wrapper-class))

- (when child

- (setf (gethash (smoke::pointer child) *children*) child))))

+ (smoke::upcast event (find-class 'child-event)))))

+ (smoke::disown-object (cxx:child child-event))))

(event.+child-removed+

(let* ((child-event (make-instance 'child-event

:pointer (smoke::upcast event

- (find-class 'child-event))

- :owned-p nil)))

- (remhash (smoke::pointer (cxx:child child-event)) *children*)))))

+ (find-class 'child-event)))))

+ ;; We receive child removed events for any QObject, wherter

+ ;; it was construted by Smoke or not. Only take ownership of objects

+ ;; that have been constructed by Smoke.

+ (when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))

+ (smoke::take-ownership (cxx:child child-event)))))))

nil)

(eval-when (:compile-toplevel :load-toplevel :execute)