Fri Apr 3 00:17:02 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
diff -rN -u old-qt.tests/qt.tests.mbd new-qt.tests/qt.tests.mbd
--- old-qt.tests/qt.tests.mbd 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/qt.tests.mbd 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,22 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+
+(in-package :sysdef-user)
+
+(define-system :qt.tests ()
+ (:version 0 0 1)
+ (:documentation "Qt unit tests.")
+ (:needs :qt :qt.test :FiveAM :trivial-garbage)
+ (:components
+ ("src" module
+ (:components "package"
+ ("tests" (:needs "package"))
+ ("qbytearray" (:needs "tests"))
+ ("qstring" (:needs "tests"))
+ ("overload" (:needs "tests"))
+ ("gc" (:needs "tests"))
+ ("variant" (:needs "tests"))
+ ("application" (:needs "tests"))
+ ("signal-slot" (:needs "tests"))
+ ("thread" (:needs "tests"))
+ ("properties" (:needs "tests"))
+ ("click" (:needs "tests"))))))
diff -rN -u old-qt.tests/src/application.lisp new-qt.tests/src/application.lisp
--- old-qt.tests/src/application.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/application.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,26 @@
+(in-package :qt.tests)
+
+(5am:in-suite :qt.suite)
+
+(5am:test with-app
+ "Tests qt:with-app and qt:with-core-app"
+ (5am:for-all ((core-p (5am:gen-one-element nil t)))
+ (5am:is (eql nil (qt:app-p)))
+ (if core-p
+ (qt:with-core-app
+ (5am:is (eql t (qt:app-p)))
+ (5am:is (typep (qt:app) (find-class 'qt:core-application)))
+ (cxx:set-object-name (qt:app) "core-app")) ;; test for memfault
+ (qt:with-app
+ (5am:is (eql t (qt:app-p)))
+ (5am:is (typep (qt:app) (find-class 'qt:application)))
+ (cxx:set-object-name (qt:app) "app")))
+ (5am:is (eql nil (qt:app-p)))))
+
+(5am:test application-nest
+ "Test qt:with-core-app nesting."
+ (qt:with-core-app
+ (5am:is (eql (qt:app) (qt:core-application.instance)))
+ (qt:with-core-app
+ (5am:is (eql (qt:app) (qt:core-application.instance))))))
+
diff -rN -u old-qt.tests/src/click.lisp new-qt.tests/src/click.lisp
--- old-qt.tests/src/click.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/click.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,41 @@
+(in-package :qt.tests)
+
+(5am:in-suite :qt.suite)
+
+(defclass click-test-widget (qt:push-button)
+ ()
+ (:metaclass cxx:class))
+
+(5am:test (click-test :depends-on with-app)
+ "Test clicking a button."
+ (qt:with-app
+ (let ((widget (make-instance 'click-test-widget))
+ (click-count 0))
+ (qt:connect (qt:get-signal widget "clicked()")
+ #'(lambda ()
+ (incf click-count)))
+
+ (cxx:set-text widget "Hello World")
+ (5am:is (string= "Hello World" (cxx:text widget)))
+
+ (5am:is (= 0 click-count))
+ (qt.test:test.mouse-click widget qt:+left-button+)
+ (5am:is (= 1 click-count))
+ (qt.test:test.mouse-click widget qt:+right-button+)
+ (5am:is (= 1 click-count)))))
+
+(5am:test (click-test-bool :depends-on click-test)
+ "Test clicking a button (bool argument)."
+ (qt:with-app
+ (let ((widget (make-instance 'click-test-widget))
+ (click-count 0))
+ (qt:connect (qt:get-signal widget "clicked(bool)")
+ #'(lambda (checked)
+ (5am:is (eql t checked))
+ (incf click-count)))
+ (5am:is (= 0 click-count))
+ (qt.test:test.mouse-click widget qt:+left-button+)
+ (5am:is (= 1 click-count))
+ (qt.test:test.mouse-click widget qt:+left-button+)
+ (5am:is (= 2 click-count)))))
+
diff -rN -u old-qt.tests/src/gc.lisp new-qt.tests/src/gc.lisp
--- old-qt.tests/src/gc.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/gc.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,86 @@
+(in-package :qt.tests)
+
+(5am:in-suite :qt.suite)
+
+;;; The GC stuff depends on (gc :full t) to collect the consed objects.
+;;; Sometimes calling GC twice helps in sbcl.
+
+(defun test-gc (class)
+ "Returns true when some instances of class get garbage collected
+and false otherwise.
+It is not required that every instance is gc'ed, since this rarly happens
+and is not a bug."
+ (let ((objects nil))
+ (dotimes (x 9)
+ (let ((object (make-instance class)))
+ (push (make-weak-pointer object)
+ objects)))
+ (dotimes (x 2)
+ (gc :full t))
+ (5am:is (eql t
+ (some #'(lambda (o) (null (weak-pointer-value o)))
+ objects)))))
+
+(defclass lisp-object ()
+ ((a :initform (make-array '(1000 1000) :initial-element 3))
+ (b :initform (list 1 2 43)))
+ (:documentation "For the object to be (hopefully) garbage colleted
+we cons up some memory."))
+
+(5am:test gc-lisp-object
+ "Ensure that GC works for plain lisp objects."
+ (test-gc 'lisp-object))
+
+(5am:test (gc-object :depends-on gc-lisp-object)
+ "Test garbage collection of a no QObject class."
+ (test-gc 'qt:byte-array))
+
+(5am:test (gc-qobject :depends-on gc-object)
+ "Test garbage collection of a QObject."
+ (test-gc 'qt:object))
+
+(defclass my-gc-object (qt:object)
+ ()
+ (:metaclass smoke::smoke-wrapper-class))
+
+;; FIXME 5am prevents garbage collection!?
+;; use eval !?
+(defun run-gc-child ()
+ (let ((objects nil))
+ (dotimes (x 10)
+ (let ((object (make-instance 'qt:object)))
+ (make-instance 'qt:object :args (list object))
+ ;(cxx:set-parent (make-instance 'qt:object) object)
+ (push object objects)))
+ (gc :full t)))
+
+(defun run-gc-my-child ()
+ (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)))
+
+
+(5am:test (gc-child :depends-on gc-qobject)
+ "Test garbage collection of a qt:object with a parent."
+ (gc :full t)
+ (let ((count (hash-table-count smoke::*object-map*)))
+ (eval '(run-gc-child))
+ (gc :full t)
+ (gc :full t)
+ (5am:is (= count (hash-table-count smoke::*object-map*)))))
+
+(5am:test (gc-lisp-child :depends-on (and gc-child with-app))
+ "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))
+ (gc :full t)
+ (qt:core-application.send-posted-events)
+ (gc :full t)
+ (qt:core-application.send-posted-events)
+ (5am:is (= count (hash-table-count smoke::*object-map*))))))
diff -rN -u old-qt.tests/src/overload.lisp new-qt.tests/src/overload.lisp
--- old-qt.tests/src/overload.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/overload.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,23 @@
+(in-package :qt.tests)
+
+(5am:in-suite :qt.suite)
+
+(defclass my-object (qt:object)
+ ((counter :accessor counter :initform 0))
+ (:metaclass smoke::smoke-wrapper-class))
+
+(defmethod cxx:timer-event ((object my-object) &rest args)
+ (declare (ignore args))
+ (format t "TIME~%")
+ (incf (counter object)))
+
+
+;;FIXME
+#|(5am:test timer
+ (let ((object (make-instance 'my-object)))
+ (qt:init-app)
+ (5am:is (= 0 (counter object)))
+ (cxx:starttimer object 50)
+ (sleep 3)
+ (5am:is (= 1 (counter object)))))
+|#
diff -rN -u old-qt.tests/src/package.lisp new-qt.tests/src/package.lisp
--- old-qt.tests/src/package.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/package.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,3 @@
+(defpackage :qt.tests
+ (:use :cl :asdf :trivial-garbage :bordeaux-threads)
+ (:export :run))
diff -rN -u old-qt.tests/src/properties.lisp new-qt.tests/src/properties.lisp
--- old-qt.tests/src/properties.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/properties.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,31 @@
+(in-package :qt.tests)
+
+(5am:in-suite :qt.suite)
+
+;(5am:test property-list
+; "Test properties"
+; (5am:is (= 0 (length (qt:class-properties (find-class 'qt:object)))))
+; (5am:is (= 1 (length (qt:properties (make-instance 'qt:object))))))
+
+(5am:test (property :depends-on qstring)
+ "Tests get and set property string"
+ (let ((o (make-instance 'qt:object)))
+ (5am:is (eql t (qt:property-p o "objectName")))
+ (5am:is (eql t (qt:property-p o 'object-name)))
+
+ (setf (qt:property o 'object-name) "fooBar")
+ (5am:is (string= (qt:property o 'object-name) "fooBar"))
+ (5am:is (string= (qt:property o "objectName") "fooBar"))
+
+ (5am:is (eql nil (qt:property-p o 'foo)))
+ (setf (qt:property o 'foo) "bar")
+ (5am:is (eql t (qt:property-p o 'foo)))
+ (5am:is (string= (qt:property o 'foo) "bar"))))
+
+
+(5am:test property-int
+ "Test get and set property integer"
+ (let ((o (make-instance 'qt:object)))
+ (5am:for-all ((integer (5am:gen-integer)))
+ (setf (qt:property o 'foo-bar) integer)
+ (5am:is (= integer (qt:property o 'foo-bar))))))
diff -rN -u old-qt.tests/src/qbytearray.lisp new-qt.tests/src/qbytearray.lisp
--- old-qt.tests/src/qbytearray.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/qbytearray.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,17 @@
+(in-package :qt.tests)
+
+(5am:in-suite :qt.suite)
+
+
+(5am:test null-bytearray
+ "Test empty QByteArray."
+ (5am:is (string= ""
+ (cxx:data (make-instance 'qt:byte-array)))))
+
+
+(5am:test make-bytearray
+ "Tests string <-> QByteArray."
+ (5am:for-all ((string (5am:gen-string)))
+ (5am:is (string= string
+ (cxx:data (make-instance 'qt:byte-array
+ :args (list string)))))))
diff -rN -u old-qt.tests/src/qstring.lisp new-qt.tests/src/qstring.lisp
--- old-qt.tests/src/qstring.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/qstring.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,24 @@
+(in-package :qt.tests)
+
+(5am:in-suite :qt.suite)
+
+(5am:test qstring
+ "Tests string <-> QString."
+ (let ((object (make-instance 'qt:object)))
+; (5am:for-all ((string (5am:gen-string))) ;;FIXME
+ (5am:for-all ((string (5am:gen-one-element "foo"
+ "FOO bar"
+ (format nil "A~AB" #\Null)
+ "öäü")))
+ (cxx:set-object-name object string)
+ (5am:is (string= string (cxx:object-name object))))))
+
+(5am:test (string-list :depends-on qstring)
+ "Test vector <-> QStringList."
+ (5am:for-all ((vector (5am:gen-one-element #()
+ #("foo")
+ #("foo" "bar")
+ #("ä" "ö" "ü"))))
+ (let ((model (make-instance 'qt:string-list-model
+ :args (list vector))))
+ (5am:is (equalp vector (cxx:string-list model))))))
diff -rN -u old-qt.tests/src/signal-slot.lisp new-qt.tests/src/signal-slot.lisp
--- old-qt.tests/src/signal-slot.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/signal-slot.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,121 @@
+(in-package :qt.tests)
+(declaim (optimize (debug 3)))
+
+(5am:in-suite :qt.suite)
+
+(5am:test simple-signal-slot
+ "Test custom signal to custom slot connection."
+ (let ((counter 0))
+ (let ((my-signal (make-instance 'qt:qsignal))
+ (my-slot (qt::make-slot #'(lambda () (incf counter))
+ nil)))
+
+ (qt:connect my-signal my-slot)
+ (funcall my-signal)
+ (5am:is (= 1 counter)))))
+
+(5am:test (emit-int-signal :depends-on with-app)
+ "Emits a signal with a C++ integer argument to a C++ slot."
+ (qt:with-core-app
+ (let ((my-signal (qt:make-signal))
+ (label (make-instance 'qt:label)))
+ (qt:connect my-signal (qt:get-slot label "setNum(int)"))
+ (5am:for-all ((number (5am:gen-integer)))
+ (funcall my-signal number)
+ (5am:is (eql number (read-from-string (cxx:text label))))))))
+
+(5am:test (emit-float-signal :depends-on with-app)
+ "Emits a signal with a C++ integer argument to a C++ slot."
+ (qt:with-core-app
+ (let ((my-signal (qt:make-signal))
+ (label (make-instance 'qt:label)))
+ (qt:connect my-signal (qt:get-slot label "setNum(double)"))
+ (5am:for-all ((number (5am:gen-float :bound 100
+ :type 'double-float)))
+ (funcall my-signal number)
+ (5am:is (< (abs (- number (read-from-string (cxx:text label))))
+ 0.001))))))
+
+(5am:test emit-bool-signal
+ "Emits a signal with an boolean C++ argument to a C++ slot."
+ (qt:with-app
+ (let ((my-signal (qt:make-signal))
+ (widget (make-instance 'qt:check-box)))
+ (qt:connect my-signal (qt:get-slot widget "setChecked(bool)"))
+ (5am:for-all ((enable (5am:gen-one-element t nil)))
+ (funcall my-signal enable)
+ (5am:is (eql enable (cxx:is-checked widget)))))))
+
+
+(5am:test (emit-qstring-signal :depends-on (and qstring with-app))
+ "Emits a signal with a C++ QString argument to a C++ slot."
+ (qt:with-app
+ (let ((my-signal (qt:make-signal))
+ (widget (make-instance 'qt:widget)))
+ (qt:connect my-signal (qt:get-slot widget "setWindowTitle(QString)"))
+
+ ;; (5am:for-all ((title (5am:gen-string)))
+ ;; FIXME fails for gen-string (some UTF-8 problem?)
+ (5am:for-all ((title (5am:gen-one-element "foo" "FooBar" "öäü")))
+ (funcall my-signal title)
+ (5am:is (string= title (cxx:window-title widget)))))))
+
+;; FIXME in reality the lisp wrapper object get passed.
+(5am:test (arg-signal-slot :depends-on simple-signal-slot)
+ "Passing an C++ class as argument to an slot."
+ (let ((size nil))
+ (let ((my-signal (qt:make-signal))
+ (my-slot (qt:make-slot #'(lambda (s)
+ (5am:is (typep s (find-class 'qt:size)))
+ (setf size (cons (cxx:width s)
+ (cxx:height s))))
+ (list (find-class 'qt:size)))))
+ (qt:connect my-signal my-slot)
+ (funcall my-signal (make-instance 'qt:size :args '(3 7)))
+ (5am:is (= 3 (first size)))
+ (5am:is (= 7 (rest size))))))
+
+
+(5am:test (lisp-arg-signal-slot :depends-on simple-signal-slot)
+ "Pass a lisp object over a signal-slot connection."
+ (let ((num 1d0)
+ (ret nil))
+ (let ((my-signal (qt:make-signal (find-class 'double-float)))
+ (my-slot (qt:make-slot #'(lambda (d)
+ (5am:is (eq d num))
+ (setf ret d))
+ (list (find-class 'double-float)))))
+ (qt:connect my-signal my-slot)
+ (funcall my-signal num))
+ (5am:is (eq ret num))))
+
+(5am:test (lisp-two-arg-signal-slot :depends-on lisp-arg-signal-slot)
+ "Pass a lisp object over a signal-slot connection."
+ (let ((num 1d0)
+ (count 0))
+ (let ((my-signal (make-instance 'qt:qsignal))
+ (my-slot (qt::make-slot #'(lambda (a b)
+ (5am:is (eq a num))
+ (5am:is (eql t b))
+ (incf count))
+ (mapcar #'find-class '(double-float t)))))
+ (qt:connect my-signal my-slot)
+ (funcall my-signal num t))
+ (5am:is (= 1 count))))
+
+(defparameter *destroyed* nil)
+
+(defun test-destroyed-signal ()
+ (let ((object (make-instance 'qt:object)))
+ (qt:connect (qt:get-signal object "destroyed()")
+ #'(lambda () (setf *destroyed* t)))
+ (sb-ext:gc :full t)
+ (5am:is (eql nil *destroyed*)))
+ (sb-ext:gc :full t))
+
+(5am:test (destroyed-signal :depends-on gc-qobject)
+ "Receive a destroy signal for a QObject."
+ (setf *destroyed* nil)
+ (test-destroyed-signal)
+ (sb-ext:gc :full t)
+ (5am:is (eql t *destroyed*)))
diff -rN -u old-qt.tests/src/tests.lisp new-qt.tests/src/tests.lisp
--- old-qt.tests/src/tests.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/tests.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,13 @@
+(in-package :qt.tests)
+
+(5am:def-suite :qt.suite :description "Qt tests")
+
+(5am:in-suite :qt.suite)
+
+(defun run ()
+; (let ((5am:*debug-on-failure* t)
+; (5am:*debug-on-error* t))
+ (let ((results (5am:run :qt.suite)))
+ (5am:explain! results)
+ (unless (5am:results-status results)
+ (error "Testsuite :qt.suite failed."))))
diff -rN -u old-qt.tests/src/thread.lisp new-qt.tests/src/thread.lisp
--- old-qt.tests/src/thread.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/thread.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,40 @@
+(in-package :qt.tests)
+
+(5am:in-suite :qt.suite)
+
+;;; FIXME implement something sensibel and test
+;;; that it realy tests for races.
+
+
+(defmacro parallel-test (&body body)
+ "Executes BODY concurrently by using threads and tests
+wherther all tests are successfull."
+ (let ((threads (gensym))
+ (thread (gensym)))
+ `(let ((,threads nil))
+ (with-timeout (5)
+ (dotimes (,(gensym) 2)
+ (push (make-thread #'(lambda () ,@body))
+ ,threads))
+ (dolist (,thread ,threads)
+ (5am:is (eql (5am:results-status (join-thread ,thread))
+ t)))))))
+
+#|
+(5am:test (bytearray-threads :depends-on make-bytearray)
+ "Concurrent qbytearray creation."
+ (parallel-test
+ (dotimes (x 5)
+ (5am:run 'make-bytearray))))
+ |#
+
+;; FIXME this test does not work realibly
+#|
+(5am:test (gc-object-threads :depends-on gc-object)
+ "Concurrent garbage collenction."
+ (parallel-test
+ (dotimes (x 2)
+ (5am:run 'gc-object))))
+
+
+|#
diff -rN -u old-qt.tests/src/variant.lisp new-qt.tests/src/variant.lisp
--- old-qt.tests/src/variant.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/src/variant.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,22 @@
+(in-package :qt.tests)
+
+(5am:in-suite :qt.suite)
+
+(5am:test (variant-string :depends-on qstring)
+ "Test qt:variant <-> string conversion."
+; (5am:for-all ((string (5am:gen-string)))
+ (5am:for-all ((string (5am:gen-one-element "foo"
+ "Foo Bar")))
+ (5am:is (string= string (qt:from-variant (qt:make-variant string))))))
+
+(5am:test variant-int
+ "Test qt:variant <-> string conversion."
+ (5am:for-all ((integer (5am:gen-integer)))
+ (5am:is (= integer (qt:from-variant (qt:make-variant integer))))))
+
+(5am:test lisp-variant
+ "Test qt:variant <-> lisp object conversion."
+ (5am:for-all ((object (5am:gen-one-element #(1 2 3)
+ (list "foo" "bar"))))
+ (5am:is (eq object (qt:from-variant (qt:make-lisp-variant object))))))
+
diff -rN -u old-qt.tests/tests/test.lisp new-qt.tests/tests/test.lisp
--- old-qt.tests/tests/test.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.tests/tests/test.lisp 2014-10-30 07:03:39.000000000 +0100
@@ -0,0 +1,3 @@
+(in-package :qt.tests)
+
+(run)