Wed Jun 10 14:09:14 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Test gc cycle and non cxx:object parent
diff -rN -u old-qt.tests/src/gc.lisp new-qt.tests/src/gc.lisp
--- old-qt.tests/src/gc.lisp 2014-10-30 07:02:58.000000000 +0100
+++ new-qt.tests/src/gc.lisp 2014-10-30 07:02:58.000000000 +0100
@@ -58,7 +58,6 @@
(let ((objects nil))
(dotimes (x 10)
(let ((object (make-instance 'qt:object)))
-; (cxx:set-parent (make-instance 'my-gc-object) object)
(make-instance 'my-gc-object :args (list object))
(push object objects)))
(gc :full t)))
@@ -69,20 +68,70 @@
(gc :full t)
(let ((count (hash-table-count smoke::*object-map*)))
(eval '(run-gc-child))
+ (eval '(gc :full t))
(gc :full t)
(gc :full t)
- (5am:is (= count (hash-table-count smoke::*object-map*)))))
+ (5am:is (>= count (hash-table-count smoke::*object-map*)))))
-(5am:test (gc-lisp-child :depends-on (and gc-child with-app))
+;(5am:test (gc-lisp-child :depends-on (and gc-child with-app))
+(5am:test gc-lisp-child
"Test garbage collection of a qt:object with a parent."
(gc :full t)
(qt:with-core-app
(let ((count (hash-table-count smoke::*object-map*)))
(eval '(run-gc-my-child))
+ ;; a.k.a :really-full ;)
(gc :full t)
(qt:core-application.send-posted-events)
+ (eval '(gc :full t))
+ (qt:core-application.send-posted-events)
+ (eval '(gc :full t))
+ (qt:core-application.send-posted-events)
(gc :full t)
(qt:core-application.send-posted-events)
-
;; allow some objects to be not collected
(5am:is (>= (+ count 2) (hash-table-count smoke::*object-map*))))))
+
+(defun test-gc-cycle ()
+ (qt:with-core-app
+ (dotimes (i 10)
+ (let ((timer (make-instance 'qt:timer)))
+ (qt:connect (qt:get-signal timer "timeout()")
+ #'(lambda ()
+ (format *debug-io* "Timeout ~A" timer)))))
+ (gc :full t)
+ (qt:core-application.send-posted-events)
+ (gc :full t)
+ (qt:core-application.send-posted-events)))
+
+(5am:test (gc-cycle :depends-on gc-lisp-child)
+ "Test GC a unreacable cycle."
+ ;; timer -> qslot -> closure(lambda)
+ ;; ^------------------/
+ (qt:with-core-app
+ (let ((objects (hash-table-count smoke::*object-map*)))
+ (eval '(test-gc-cycle))
+ (eval '(gc :full t))
+ (qt:core-application.send-posted-events)
+ (eval '(gc :full t))
+ (qt:core-application.send-posted-events)
+ (gc :full t)
+ (qt:core-application.send-posted-events)
+ (gc :full t)
+ (5am:is (>= objects (hash-table-count smoke::*object-map*))))))
+
+(5am:test ownership-transfer-no-wrapper
+ "Test ownership tranasfer of a QObject without a wrapper."
+ (let ((grand-parent (make-instance 'qt:object)))
+ (let* ((parent (make-instance 'qt:object :args (list grand-parent)))
+ (object (make-instance 'my-object :args (list parent))))
+ (declare (ignore object)))
+ (gc :full t)
+ (qt:core-application.send-posted-events)
+ (gc :full t)
+ (qt:core-application.send-posted-events)
+ (5am:is (member (find-class 'my-object)
+ (loop for c across (cxx:children grand-parent) append
+ (map 'list #'class-of
+ (cxx:children c)))))))
+
diff -rN -u old-qt.tests/src/signal-slot.lisp new-qt.tests/src/signal-slot.lisp
--- old-qt.tests/src/signal-slot.lisp 2014-10-30 07:02:58.000000000 +0100
+++ new-qt.tests/src/signal-slot.lisp 2014-10-30 07:02:58.000000000 +0100
@@ -113,6 +113,10 @@
(5am:is (eq nil *destroyed*)))
(tg:gc :full t))
+;; SBCL runs the finalizer when the object has been garbage collected,
+;; thus its children could be to and thus the destroyed() signal is not
+;; received
+#-(or sbcl cmucl)
(5am:test (destroyed-signal :depends-on gc-qobject)
"Receive a destroy signal for a QObject."
(setf *destroyed* nil)