darcs - qt.tests

1 (in-package :qt.tests)

3 (5am:in-suite :qt.suite)

4 ;;; The GC stuff depends on (gc :full t) to collect the consed objects.

5 ;;; Sometimes calling GC twice helps in SBCL.

7 (defun test-gc (class)

8 "Returns true when some instances of class get garbage collected

9 and false otherwise.

10 It is not required that every instance is gc'ed, since this rarely happens

11 and is not a bug."

12 (let ((objects nil))

13 (dotimes (x 30)

14 (let ((object (make-instance class)))

15 (push (make-weak-pointer object)

16 objects)))

17 (dotimes (x 2)

18 (gc :full t))

19 (5am:is (eq t (some #'(lambda (o) (null (weak-pointer-value o)))

20 objects)))))

22 (defclass lisp-object ()

23 ((a :initform (make-array '(1000 1000) :initial-element 3))

24 (b :initform (list 1 2 43)))

25 (:documentation "For the object to be (hopefully) garbage collected

26 we cons up some memory."))

28 (5am:test gc-lisp-object

29 "Ensure that GC works for plain lisp objects."

30 (test-gc 'lisp-object))

32 (5am:test (gc-object :depends-on gc-lisp-object)

33 "Test garbage collection of a no QObject class."

34 (test-gc 'qt:byte-array))

36 (5am:test (gc-qobject :depends-on gc-object)

37 "Test garbage collection of a QObject."

38 (test-gc 'qt:object))

40 (5am:test gc-multi-object

41 "Test garbage collection of a custom object that has two C++ superclasses."

42 (test-gc 'my-multi-object))

44 (defclass my-gc-object (qt:object)

45 ()

46 (:metaclass cxx:class))

48 ;; FIXME 5am prevents garbage collection!?

49 ;; use eval !?

50 (defun run-gc-child ()

51 (let ((objects nil))

52 (dotimes (x 10)

53 (let ((object (make-instance 'qt:object)))

54 (make-instance 'qt:object :args (list object))

55 ;;(cxx:set-parent (make-instance 'qt:object) object)

56 (push object objects)))

57 (gc :full t)))

59 (defun run-gc-my-child ()

60 (let ((objects nil))

61 (dotimes (x 10)

62 (let ((object (make-instance 'qt:object)))

63 (make-instance 'my-gc-object :args (list object))

64 (push object objects)))

65 (gc :full t)))

68 (5am:test (gc-child :depends-on gc-qobject)

69 "Test garbage collection of a qt:object with a parent."

70 (gc :full t)

71 (gc :full t)

72 (qt:with-core-app ()

73 (let ((count (hash-table-count smoke::*object-map*)))

74 (eval '(run-gc-child))

75 (eval '(gc :full t))

76 (qt:core-application.send-posted-events)

77 (gc :full t)

78 (qt:core-application.send-posted-events)

79 (gc :full t)

80 (5am:is (>= count (hash-table-count smoke::*object-map*))))))

82 (5am:test (gc-lisp-child :depends-on (and gc-child with-app))

83 "Test garbage collection of a qt:object with a parent."

84 (gc :full t)

85 (qt:with-core-app ()

86 (let ((count (hash-table-count smoke::*object-map*)))

87 (eval '(run-gc-my-child))

88 ;; a.k.a :really-full ;)

89 (gc :full t)

90 (qt:core-application.send-posted-events)

91 (eval '(gc :full t))

92 (qt:core-application.send-posted-events)

93 (eval '(gc :full t))

94 (qt:core-application.send-posted-events)

95 (gc :full t)

96 (qt:core-application.send-posted-events)

97 ;; allow some objects to be not collected

98 (5am:is (>= (+ count 2) (hash-table-count smoke::*object-map*))))))

100 (defun test-gc-cycle ()

101 (dotimes (i 10)

102 (let ((timer (make-instance 'qt:timer)))

103 (qt:connect (qt:get-signal timer "timeout()")

104 #'(lambda ()

105 (format *debug-io* "Timeout ~A" timer)))))

106 (gc :full t)

107 (qt:core-application.send-posted-events)

108 (gc :full t)

109 (qt:core-application.send-posted-events))

110

111 (5am:test (gc-cycle :depends-on gc-lisp-child)

112 "Test GC a unreachable cycle."

113 ;; timer -> qslot -> closure(lambda)

114 ;; ^------------------/

115 (qt:with-core-app ()

116 (let ((objects (hash-table-count smoke::*object-map*)))

117 (eval '(test-gc-cycle))

118 (eval '(gc :full t))

119 (qt:core-application.send-posted-events)

120 (eval '(gc :full t))

121 (qt:core-application.send-posted-events)

122 (gc :full t)

123 (qt:core-application.send-posted-events)

124 (gc :full t)

125 (5am:is (>= (+ 2 objects) (hash-table-count smoke::*object-map*))))))

126

127 (5am:test (ownership-transfer-no-wrapper :depends-on gc-lisp-child)

128 "Test ownership transfer of a QObject without a wrapper."

129 (let ((grand-parent (make-instance 'qt:object)))

130 (setf (cxx:object-name grand-parent) "grand parent")

131 (let* ((parent (make-instance 'qt:object :args (list grand-parent)))

132 (object (make-instance 'my-object :args (list parent))))

133 (setf (cxx:object-name parent) "parent"

134 (cxx:object-name object) "child"))

135 (gc :full t)

136 (qt:core-application.send-posted-events)

137 (gc :full t)

138 (qt:core-application.send-posted-events)

139 (5am:is (member (find-class 'my-object)

140 (loop for c across (cxx:children grand-parent) append

141 (map 'list #'class-of

142 (cxx:children c)))))))

143

144 (5am:test (gc-non-smoke-object :depends-on gc-lisp-child)

145 "Test adding a child to a non smoke object."

146 (qt:with-app ()

147 (let ((model (make-instance 'qt:string-list-model :arg0 #("a" "b" "c")))

148 (view (make-instance 'qt:list-view))

149 (counter 0))

150 (setf (cxx:model view) model)

151 (qt:connect (qt:get-signal (cxx:selection-model view)

152 "selectionChanged(QItemSelection, QItemSelection)")

153 #'(lambda (selected deselected)

154 (declare (ignore selected deselected))

155 (incf counter)))

156 (cxx:destroyed (cxx:selection-model view)

157 (cxx:selection-model view))

158 (gc :full t)

159 (qt:core-application.send-posted-events)

160 (gc :full t)

161 (qt:core-application.send-posted-events)

162 (5am:is (= 0 counter))

163 (cxx:select (cxx:selection-model view)

164 (cxx:index model 0)

165 qt:item-selection-model.+toggle+)

166 (5am:is (= 1 counter))

167 (cxx:select (cxx:selection-model view)

168 (cxx:index model 1)

169 qt:item-selection-model.+toggle+)

170 (5am:is (= 2 counter)))))

171

172 #|

173 ;; FIXME

174 (5am:test (gc-variant-cycle :depends-on gc-lisp-child lisp-variant)

175 (let ((finalized-p))

176 (let* ((list (list nil))

177 (variant (qt:make-lisp-variant list)))

178 (setf (first list)

179 variant)

180 (tg:finalize list #'(lambda () (setf finalized-p t)))

181 (5am:is (eq nil finalized-p)))

182 (gc :full t)

183 (gc :full t)

184 (5am:is (eq t finalized-p))))

185

186 |#