Sat Apr 3 21:13:24 CEST 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Test static member variable access using slot-value with a class object.

Sat Apr 3 14:52:50 CEST 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Test slot-value for C++ attributes.

Sat Apr 3 14:50:36 CEST 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Test qt.opengl conversions.

Sat Feb 20 22:06:45 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Test (qt:value (qt:make-variant qt:+green+))

Sat Feb 20 19:06:27 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Test overload resolution exact match for long and ulong.

Mon Jan 25 22:13:40 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Test QGraphicsScene::setItem

Mon Jan 25 19:51:13 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Test QList translation

Sat Jan 23 23:18:13 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Test to QVector<QPoint> translation.

Sun Jan 10 09:57:03 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* ASDF & modular smoke.

Sun Dec 13 13:45:36 CET 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Support ASDF instead of Mudballs.

Wed Sep 2 14:02:23 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Test Lisp to QList<QVariant> and test user conversion sequence for return values.

Sun Aug 30 16:18:04 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Test multiple C++ superclasses.

Thu Aug 27 10:41:11 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Updates for the new smokegenerator.

* workaround missing default arguments for QTest::mouseClick

* test const correctness.

Thu Jul 23 00:22:47 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Qt property names are symbols in the keyword package.

Wed Jul 1 13:02:20 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Use new qt:with-app

Wed Jul 1 00:48:36 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* CCL fixes

Sun Jun 21 11:21:04 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* uses-macros-from :smoke

Thu Jun 11 20:52:38 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* The Qt modules are now all in :qt

--- old-qt.tests/cl-smoke.qt.tests.asd 1970-01-01 01:00:00.000000000 +0100

+++ new-qt.tests/cl-smoke.qt.tests.asd 2014-10-30 07:56:41.000000000 +0100

@@ -0,0 +1,35 @@

+(defsystem :cl-smoke.qt.tests

+ :name :cl-smoke.qt.tests

+ :version (0 0 1)

+ :author "Tobias Rautenkranz"

+ :license "GPL with linking exception"

+ :description "Qt unit tests."

+ :depends-on (:cl-smoke.qt.test :cl-smoke.qt.gui :cl-smoke.qt.opengl

+ :FiveAM :trivial-garbage :cl-smoke.smoke)

+

+ :components

+ ((:module "src"

+ :components

+ ((:file "package")

+ (:file "tests" :depends-on ("package"))

+ (:file "qbytearray" :depends-on ("tests"))

+ (:file "qstring" :depends-on ("tests"))

+ (:file "qvector" :depends-on ("tests"))

+ (:file "qlist" :depends-on ("tests"))

+ (:file "graphics-item" :depends-on ("tests"))

+ (:file "overload" :depends-on ("tests"))

+ (:file "opengl" :depends-on ("tests"))

+ (:file "gc" :depends-on ("tests" "object"))

+ (:file "variant" :depends-on ("tests"))

+ (:file "application" :depends-on ("tests"))

+ (:file "signal-slot" :depends-on ("tests"))

+ (:file "operators" :depends-on ("tests"))

+ (:file "undo" :depends-on ("tests"))

+ (:file "abort" :depends-on ("tests"))

+ (:file "object" :depends-on ("tests"))

+ (:file "thread" :depends-on ("tests"))

+ (:file "properties" :depends-on ("tests"))

+ (:file "click" :depends-on ("tests"))))))

+

+(defmethod perform ((operation test-op) (c (eql (find-system :cl-smoke.qt.tests))))

+ (funcall (intern (string :run) (string :qt.tests))))

--- old-qt.tests/qt.tests.mbd 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/qt.tests.mbd 1970-01-01 01:00:00.000000000 +0100

@@ -1,29 +0,0 @@

-;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-

-

-(in-package :sysdef-user)

-

-(define-system :qt.tests ()

- (:version 0 0 1)

- (:documentation "Qt unit tests.")

- (:author "Tobias Rautenkranz")

- (:license "GPL with linking exception")

- (: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"))

- ("operators" (:needs "tests"))

- ("undo" (:needs "tests"))

- ("abort" (:needs "tests"))

- ("object" (:needs "tests"))

- ("thread" (:needs "tests"))

- ("properties" (:needs "tests"))

- ("click" (:needs "tests"))))))

--- old-qt.tests/src/abort.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/abort.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -5,12 +5,12 @@

(defmacro with-invoke-restart ((condition restart &optional handler) &body body)

"Invokes RESTART when CONDITION is signaled in BODY."

(alexandria:with-gensyms (c)

- `(handler-bind ((,condition #'(lambda (,c)

- (declare (ignore ,c))

- (assert (find-restart ',restart))

- ,(when handler `(funcall ,handler))

- (invoke-restart ',restart))))

- ,@body)))

+ `(handler-bind ((,condition #'(lambda (,c)

+ (declare (ignore ,c))

+ (assert (find-restart ',restart))

+ ,(when handler `(funcall ,handler))

+ (invoke-restart ',restart))))

+ ,@body)))

(define-condition no-ticket (error) ())

@@ -23,18 +23,18 @@

"Test aborting the event loop."

(dotimes (i 3)

(bt:with-timeout (5)

- (with-invoke-restart (no-ticket qt::abort-app)

- (qt:with-app

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

- (continued-p))

- (cxx:set-single-shot timer t)

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

- #'(lambda ()

- (cerror "ignore" (make-condition 'no-ticket))

- (setf continued-p t)))

- (cxx:start timer 0)

- (qt:exec)

- (5am:is (eq continued-p t))))))))

+ (with-invoke-restart (no-ticket qt::abort-app)

+ (qt:with-app ()

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

+ (continued-p))

+ (cxx:set-single-shot timer t)

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

+ #'(lambda ()

+ (cerror "ignore" (make-condition 'no-ticket))

+ (setf continued-p t)))

+ (cxx:start timer 0)

+ (qt:exec)

+ (5am:is (eq continued-p t))))))))

(defclass error-object (qt:object)

()

@@ -45,30 +45,30 @@

(error (make-condition 'no-ticket)))

(5am:test error-in-callback-return

- "Test retruning from a void method on error."

- (qt:with-core-app

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

- (restarted-p))

- (with-invoke-restart (no-ticket smoke::return

- #'(lambda () (setf restarted-p t)))

- (cxx:start-timer object 0)

- (qt:core-application.process-events))

- (5am:is (eq t restarted-p)))))

+ "Test returning from a void method on error."

+ (qt:with-core-app ()

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

+ (restarted-p))

+ (with-invoke-restart (no-ticket smoke::return

+ #'(lambda () (setf restarted-p t)))

+ (cxx:start-timer object 0)

+ (qt:core-application.process-events))

+ (5am:is (eq t restarted-p)))))

(5am:test error-in-callback-default

"Test calling the default C++ method on error in the user defined method."

- (qt:with-core-app

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

- (restarted-p))

- (with-invoke-restart (no-ticket smoke::call-default

- #'(lambda () (setf restarted-p t)))

- (cxx:start-timer object 0)

- (qt:core-application.process-events))

- (5am:is (eq t restarted-p)))))

+ (qt:with-core-app ()

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

+ (restarted-p))

+ (with-invoke-restart (no-ticket smoke::call-default

+ #'(lambda () (setf restarted-p t)))

+ (cxx:start-timer object 0)

+ (qt:core-application.process-events))

+ (5am:is (eq t restarted-p)))))

(5am:test error-in-slot

"Test skipping a slot function when it signals an error."

- (qt:with-core-app

+ (qt:with-core-app ()

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

(continued-p))

(with-invoke-restart (no-ticket continue

@@ -80,3 +80,11 @@

(cxx:start timer 0)

(qt:core-application.process-events))

(5am:is (eq t continued-p)))))

+

+

+(5am:test msg-handler

+ "Test catching Q_ASSERTS."

+ (5am:signals error

+ (qt:qt-assert ":qt.tests msg-handler test assert"

+ "abort.lisp"

+ -1)))

--- old-qt.tests/src/application.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/application.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -5,32 +5,34 @@

(5am:test with-app

"Tests qt:with-app and qt:with-core-app"

(let ((nested (qt:app-p)))

- (5am:for-all ((core-p (5am:gen-one-element nil t)))

- (unless nested

- (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)))

- (setf (cxx: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)))

- (setf (cxx:object-name (qt:app)) "app")))

- (unless nested

- (5am:is (eql nil (qt:app-p)))))))

+ (5am:for-all ((core-p (5am:gen-one-element nil t)))

+ (unless nested

+ (5am:is (eql nil (qt:app-p))))

+ (if core-p

+ (qt:with-core-app ()

+ (5am:is (eql t (qt:app-p)))

+ (5am:is (string= "QCoreApplication"

+ (cxx:class-name (cxx:meta-object (qt:app)))))

+ (setf (cxx:object-name (qt:app)) "core-app")) ;; test for memfault

+ (qt:with-app ()

+ (5am:is (eql t (qt:app-p)))

+ (5am:is (string= "QApplication"

+ (cxx:class-name (cxx:meta-object (qt:app)))))

+ (setf (cxx:object-name (qt:app)) "app")))

+ (unless nested

+ (5am:is (eql nil (qt:app-p)))))))

(5am:test application-nest

"Test qt:with-core-app nesting."

- (qt:with-core-app

+ (qt:with-core-app ()

(5am:is (eql (qt:app) (qt:core-application.instance)))

- (qt:with-core-app

+ (qt:with-core-app ()

(5am:is (eql (qt:app) (qt:core-application.instance))))

(5am:is (eql (qt:app) (qt:core-application.instance)))))

(5am:test application-widgetlist

"Test cxx:all-widgets"

- (qt:with-app

- (5am:is (= 0 (length (cxx:all-widgets (qt:app)))))

- (let ((w (make-instance 'qt:widget)))

- (5am:is (find w (cxx:all-widgets (qt:app)))))))

+ (qt:with-app ()

+ (5am:is (= 0 (length (cxx:all-widgets (qt:app)))))

+ (let ((w (make-instance 'qt:widget)))

+ (5am:is (find w (cxx:all-widgets (qt:app)))))))

--- old-qt.tests/src/click.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/click.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -8,26 +8,28 @@

(5am:test (click-test :depends-on with-app)

"Test clicking a button."

- (qt:with-app

+ (qt:with-app ()

(let ((widget (make-instance 'click-test-widget))

(click-count 0))

(qt:connect (qt:get-signal widget "clicked()")

#'(lambda ()

(5am:is (eq widget (qt:sender)))

(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+)

+ (qt:test.mouse-click widget qt:+left-button+

+ 0 (make-instance 'qt:point) -1)

(5am:is (= 1 click-count))

- (qt.test:test.mouse-click widget qt:+right-button+)

+ (qt:test.mouse-click widget qt:+right-button+

+ 0 (make-instance 'qt:point) -1)

(5am:is (= 1 click-count)))))

(5am:test (click-test-bool :depends-on click-test)

"Test clicking a button (bool argument)."

- (qt:with-app

+ (qt:with-app ()

(let ((widget (make-instance 'click-test-widget))

(click-count 0))

(qt:connect (qt:get-signal widget "clicked(bool)")

@@ -35,14 +37,16 @@

(5am:is (eql nil checked))

(incf click-count)))

(5am:is (= 0 click-count))

- (qt.test:test.mouse-click widget qt:+left-button+)

+ (qt:test.mouse-click widget qt:+left-button+

+ 0 (make-instance 'qt:point) -1)

(5am:is (= 1 click-count))

- (qt.test:test.mouse-click widget qt:+left-button+)

+ (qt:test.mouse-click widget qt:+left-button+

+ 0 (make-instance 'qt:point) -1)

(5am:is (= 2 click-count)))))

(5am:test (click-test-bool-this :depends-on click-test)

"Test clicking a button (bool argument) for a function with this argument."

- (qt:with-app

+ (qt:with-app ()

(let ((widget (make-instance 'click-test-widget))

(click-count 0))

(qt:connect (qt:get-signal widget "clicked(bool)")

@@ -52,7 +56,9 @@

(5am:is (eq widget object))

(incf click-count))))

(5am:is (= 0 click-count))

- (qt.test:test.mouse-click widget qt:+left-button+)

+ (qt:test.mouse-click widget qt:+left-button+

+ 0 (make-instance 'qt:point) -1)

(5am:is (= 1 click-count))

- (qt.test:test.mouse-click widget qt:+left-button+)

+ (qt:test.mouse-click widget qt:+left-button+

+ 0 (make-instance 'qt:point) -1)

(5am:is (= 2 click-count)))))

--- old-qt.tests/src/gc.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/gc.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -1,30 +1,28 @@

(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.

+;;; 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

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

and is not a bug."

(let ((objects nil))

- (dotimes (x 9)

+ (dotimes (x 30)

(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)))))

+ (5am:is (eq 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

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

we cons up some memory."))

(5am:test gc-lisp-object

@@ -39,6 +37,10 @@

"Test garbage collection of a QObject."

(test-gc 'qt:object))

+(5am:test gc-multi-object

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

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

+

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

()

(:metaclass cxx:class))

@@ -50,7 +52,7 @@

(dotimes (x 10)

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

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

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

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

(push object objects)))

(gc :full t)))

@@ -66,17 +68,21 @@

(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))

- (eval '(gc :full t))

- (gc :full t)

- (gc :full t)

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

+ (gc :full t)

+ (qt:with-core-app ()

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

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

+ (eval '(gc :full t))

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

+ (gc :full t)

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

+ (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

+ (qt:with-core-app ()

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

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

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

@@ -103,27 +109,29 @@

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

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

- "Test GC a unreacable cycle."

+ "Test GC a unreachable 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*))))))

+ (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 (>= (+ 2 objects) (hash-table-count smoke::*object-map*))))))

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

- "Test ownership tranasfer of a QObject without a wrapper."

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

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

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

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

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

- (declare (ignore object)))

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

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

(gc :full t)

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

(gc :full t)

@@ -131,33 +139,48 @@

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

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

(map 'list #'class-of

- (cxx:children c)))))))

+ (cxx:children c)))))))

-

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

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

- (qt:with-app

- (let ((model (make-instance 'qt:string-list-model

- :args (list #("a" "b" "c"))))

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

- (counter 0))

- (setf (cxx:model view) model)

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

- "selectionChanged(QItemSelection, QItemSelection)")

- #'(lambda (selected deselected)

- (declare (ignore selected deselected))

- (incf counter)))

- (gc :full t)

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

- (gc :full t)

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

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

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

- (cxx:index model 0)

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

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

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

- (cxx:index model 1)

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

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

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

+ (qt:with-app ()

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

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

+ (counter 0))

+ (setf (cxx:model view) model)

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

+ "selectionChanged(QItemSelection, QItemSelection)")

+ #'(lambda (selected deselected)

+ (declare (ignore selected deselected))

+ (incf counter)))

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

+ (cxx:selection-model view))

+ (gc :full t)

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

+ (gc :full t)

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

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

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

+ (cxx:index model 0)

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

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

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

+ (cxx:index model 1)

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

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

+#|

+;; FIXME

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

+ (let ((finalized-p))

+ (let* ((list (list nil))

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

+ (setf (first list)

+ variant)

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

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

+ (gc :full t)

+ (gc :full t)

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

+

+|#

--- old-qt.tests/src/graphics-item.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-qt.tests/src/graphics-item.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -0,0 +1,18 @@

+(in-package :qt.tests)

+

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

+

+(5am:test set-graphics-item

+ "Ownership transfer for QGraphicsScene::setItem."

+ (qt:with-app ()

+ (let ((scene (make-instance 'qt:graphics-scene)))

+ (let ((item (make-instance 'qt:graphics-item)))

+ (cxx:set-tool-tip item "Foo")

+ (cxx:add-item scene item))

+ (tg:gc :full t)

+ (tg:gc :full t)

+ (5am:is (= 1 (length (cxx:items scene))))

+ (5am:is (string= "Foo"

+ (cxx:tool-tip (elt (cxx:items scene) 0))))

+ ;; FIXME delete QGraphicsScene before the QApplication is deleted

+ (smoke::delete-object scene))))

--- old-qt.tests/src/object.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/object.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -3,13 +3,24 @@

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

(5am:test test-children

- "Test QList<Object*> to sequence conversion."

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

- (5am:is (= 0 (length (cxx:children object))))

- (let ((children (mapcar #'(lambda (parent)

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

- (list object object object))))

- (5am:is (= (length children)

- (length (cxx:children object))))

- (dolist (c children)

- (5am:is (find c (cxx:children object)))))))

+ "Test QList<Object*> to sequence conversion."

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

+ (5am:is (= 0 (length (cxx:children object))))

+ (let ((children (mapcar #'(lambda (parent)

+ (make-instance 'qt:object :args (list parent)))

+ (list object object object))))

+ (5am:is (= (length children)

+ (length (cxx:children object))))

+ (dolist (c children)

+ (5am:is (find c (cxx:children object)))))))

+

+(defclass my-multi-object (qt:object qt:graphics-item)

+ ()

+ (:metaclass cxx:class))

+

+(5am:test multi-object

+ "Tests a custom object that has two C++ superclasses."

+ (let ((object (make-instance 'my-multi-object)))

+ (5am:is (string= "" (cxx:object-name object)))

+ (5am:is (= qt:graphics-item.+user-type+

+ (cxx:type object)))))

--- old-qt.tests/src/opengl.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-qt.tests/src/opengl.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -0,0 +1,24 @@

+(in-package :qt.tests)

+

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

+

+(5am:test gluint

+ "GLuint conversion"

+ (qt:with-app ()

+ (let* ((texture (make-instance 'qt:pixmap))

+ (gl-widget (make-instance 'qt:glwidget))

+ (id (cxx:bind-texture gl-widget texture)))

+ (5am:is (typep id '(integer 0)))

+ (cxx:delete-texture gl-widget id))))

+

+

+(5am:test glint

+ "Test GLint and GLenum conversion."

+ (qt:with-app ()

+ (let* ((texture (make-instance 'qt:pixmap))

+ (target 3553) ;(cffi:foreign-enum-value '%gl:enum :texture-2d))

+ (format 6409) ;(cffi:foreign-enum-value '%gl:enum :rgba))

+ (gl-widget (make-instance 'qt:glwidget))

+ (id (cxx:bind-texture gl-widget texture target format)))

+ (5am:is (typep id '(integer 0)))

+ (cxx:delete-texture gl-widget id))))

--- old-qt.tests/src/overload.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/overload.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -12,7 +12,7 @@

(5am:test timer

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

- (qt:with-core-app

+ (qt:with-core-app ()

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

(cxx:start-timer object 0)

(with-timeout (5)

@@ -26,7 +26,7 @@

(defmethod cxx:data ((list my-list-model) index role)

(incf (counter list))

(if (< (cxx:row index) 2)

- (qt:make-variant (cxx:row index))

+ (cxx:row index) ;; cl-smoke converts to the required qt:variant

(qt:make-variant)))

(defmethod cxx:row-count ((list my-list-model) parent)

--- old-qt.tests/src/package.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/package.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -1,3 +1,3 @@

(defpackage :qt.tests

- (:use :cl :trivial-garbage :bordeaux-threads)

+ (:use :cl :trivial-garbage :bordeaux-threads :cxx-support)

(:export :run))

--- old-qt.tests/src/properties.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/properties.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -11,10 +11,10 @@

"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)))

+ (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"))

+ (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 (string= (cxx:object-name o) "fooBar"))

@@ -35,3 +35,24 @@

(5am:for-all ((integer (5am:gen-integer)))

(setf (qt:property o 'foo-bar) integer)

(5am:is (= integer (qt:property o 'foo-bar))))))

+

+(5am:test attributes

+ "Test C++ attribute access with slot-* functions."

+ (let ((o (make-instance 'qt:object)))

+ (5am:is (slot-boundp o :static-meta-object))

+ (5am:is (slot-boundp (find-class 'qt:object) :static-meta-object))

+ (5am:is (string= "QObject"

+ (cxx:class-name

+ (slot-value o :static-meta-object))))

+ (5am:is (string= "QObject"

+ (cxx:class-name

+ (slot-value (find-class 'qt:object)

+ :static-meta-object))))

+ (5am:signals error

+ (setf (slot-value o :static-meta-object)

+ (cffi:null-pointer))))

+ (let ((data (make-instance 'qt:shared-data)))

+ (5am:is (slot-boundp data :ref))

+ (5am:for-all ((value (5am:gen-integer :min -255 :max 255)))

+ (setf (slot-value data :ref) value)

+ (5am:is (cxx:= (slot-value data :ref) value)))))

--- old-qt.tests/src/qbytearray.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/qbytearray.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -2,16 +2,28 @@

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

-

(5am:test null-bytearray

"Test empty QByteArray."

- (5am:is (string= ""

- (cxx:data (make-instance 'qt:byte-array)))))

-

+ (5am:is (string= "" (cxx:data (make-instance 'qt:byte-array)))))

(5am:test bytearray

- "Tests string <-> QByteArray."

+ "Test string <-> QByteArray."

+ (5am:for-all ((string (5am:gen-one-element "" "Foo" "bar" "öäü" "1234")))

+ (5am:is (string= string

+ (cxx:data (make-instance 'qt:byte-array

+ :arg0 string)))))

+ #-openmcl ;; FIXME utf-8 problems with Clozure cl?

(5am:for-all ((string (5am:gen-string)))

(5am:is (string= string

(cxx:data (make-instance 'qt:byte-array

- :args (list string)))))))

+ :arg0 string))))))

+

+(5am:test const-bytearray

+ "Test const QByteArray."

+ ;; Const operator[] returns a char, but the non const version a QByteRef.

+ ;; Using this to test constnes overload resolution.

+ (let ((const-array (qt:operator+ (make-instance 'qt:byte-array :arg0 "a")

+ (make-instance 'qt:byte-array :arg0 "b"))))

+ (5am:is (typep (cxx:operator[] (make-instance 'qt:byte-array :arg0 "a") 0)

+ 'qt:byte-ref))

+ (5am:is (eql #\a (cxx:operator[] const-array 0)))))

--- old-qt.tests/src/qlist.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-qt.tests/src/qlist.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -0,0 +1,11 @@

+(in-package :qt.tests)

+

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

+

+(5am:test variant-list

+ "QList<Variant>"

+ (let ((variants (vector (qt:make-variant "foo"))))

+ (5am:is (every #'cxx:=

+ variants

+ (cxx:to-list (qt:make-variant variants))))))

+

--- old-qt.tests/src/qstring.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/qstring.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -5,11 +5,12 @@

(5am:test (qstring :depends-on bytearray)

"Tests string <-> QString."

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

-; (5am:for-all ((string (5am:gen-string))) ;;FIXME

+ ;; (5am:for-all ((string (5am:gen-string))) ;; FIXME (Qt bug?)

(5am:for-all ((string (5am:gen-one-element "foo"

- "FOO bar"

- (format nil "A~AB" #\Null)

- "öäüƧЪ")))

+ "FOO bar"

+ ""

+ (format nil "A~AB" #\Null)

+ "öäüƧЪ")))

(setf (cxx:object-name object) string)

(5am:is (string= string (cxx:object-name object))))))

--- old-qt.tests/src/qvector.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-qt.tests/src/qvector.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -0,0 +1,41 @@

+(in-package :qt.tests)

+

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

+

+(5am:test qvector-qpoint

+ "Tests to QVector<QPoint> translation."

+ (let* ((points

+ (map 'vector #'(lambda (coords)

+ (make-instance 'qt:point :arg0 (first coords)

+ :arg1 (rest coords)))

+ '((9 . 8) (7 . 6) (5 . 4))))

+ (polygon (make-instance 'qt:polygon :arg0 points)))

+ (dotimes (i (length points))

+ (5am:is (= (cxx:x (aref points i))

+ (cxx:x (cxx:point polygon i))))

+ (5am:is (= (cxx:y (aref points i))

+ (cxx:y (cxx:point polygon i))))))

+ ;; Free the allocated QVector<QPoint>

+ (tg:gc :full t))

+

+(5am:test qvector-double

+ "Test QVector<double> <-> Lisp translation."

+ (5am:for-all ((pattern (5am:gen-one-element #()

+ #(1d0 2d0)

+ #(3.1415926d0 -10d0 1d10 0d0))))

+ (let ((pen (make-instance 'qt:pen))) ;; set-dash-pattern only works once!?

+ (cxx:set-dash-pattern pen pattern)

+ (5am:is (equalp pattern (cxx:dash-pattern pen))))))

+

+(5am:test qvector-uint

+ "Test QVector<unsigned int> <-> Lisp translation."

+ (let ((image (make-instance 'qt:image

+ :args (list 10 10 qt:image.+format-indexed8+)))

+ (colors (map 'vector

+ #'qt:q-rgb

+ '(1 2 44 55 255)

+ '(4 6 23 43 12)

+ '(5 0 23 12 123))))

+ (5am:is (equalp #() (cxx:color-table image)))

+ (cxx:set-color-table image colors)

+ (5am:is (equalp colors (cxx:color-table image)))))

--- old-qt.tests/src/signal-slot.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/signal-slot.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -1,5 +1,4 @@

(in-package :qt.tests)

-(declaim (optimize (debug 3)))

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

@@ -9,14 +8,14 @@

(let ((my-signal (qt:make-signal))

(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

+ (qt:with-app ()

(let ((my-signal (qt:make-signal))

(label (make-instance 'qt:label)))

(qt:connect my-signal (qt:get-slot label "setNum(int)"))

@@ -26,7 +25,7 @@

(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

+ (qt:with-app ()

(let ((my-signal (qt:make-signal))

(label (make-instance 'qt:label)))

(qt:connect my-signal (qt:get-slot label "setNum(double)"))

@@ -38,7 +37,7 @@

(5am:test emit-bool-signal

"Emits a signal with an boolean C++ argument to a C++ slot."

- (qt:with-app

+ (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)"))

@@ -49,7 +48,7 @@

(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

+ (qt:with-app ()

(let ((my-signal (qt:make-signal))

(widget (make-instance 'qt:widget)))

(qt:connect my-signal (qt:get-slot widget "setWindowTitle(QString)"))

@@ -116,7 +115,7 @@

;; 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)

+#-(or sbcl cmucl ccl)

(5am:test (destroyed-signal :depends-on gc-qobject)

"Receive a destroy signal for a QObject."

(setf *destroyed* nil)

@@ -127,52 +126,54 @@

(5am:test int-signal

"Receive a int signal."

- (qt:with-app

- (let ((spin-box (make-instance 'qt:spin-box))

- (current-value)

- (current-string-value))

- (qt:connect (qt:get-signal spin-box "valueChanged(int)")

- #'(lambda (value)

- (setf current-value value)))

- (qt:connect (qt:get-signal spin-box "valueChanged(const QString&)")

- #'(lambda (value)

- (setf current-string-value value)))

- (5am:for-all ((value (5am:gen-integer

- :min (cxx:minimum spin-box)

- :max (cxx:maximum spin-box))))

- (cxx:set-value spin-box value)

- (5am:is (= value current-value))

- (5am:is (= value (read-from-string current-string-value)))))))

+ (qt:with-app ()

+ (let ((spin-box (make-instance 'qt:spin-box))

+ (current-value)

+ (current-string-value))

+ (qt:connect (qt:get-signal spin-box "valueChanged(int)")

+ #'(lambda (value)

+ (setf current-value value)))

+ (qt:connect (qt:get-signal spin-box "valueChanged(const QString&)")

+ #'(lambda (value)

+ (setf current-string-value value)))

+ (5am:for-all ((value (5am:gen-integer

+ :min (cxx:minimum spin-box)

+ :max (cxx:maximum spin-box))))

+ (cxx:set-value spin-box value)

+ (5am:is (= value current-value))

+ (5am:is (= value (read-from-string current-string-value)))))))

(5am:test object-signal

"Receive a qt:object pointer signal."

- (qt:with-app

- (let ((button (make-instance 'qt:push-button))

- (click-count 0)

- (signal-mapper (make-instance 'qt:signal-mapper)))

- (qt:connect (qt:get-signal button "clicked()")

- (qt:get-slot signal-mapper "map()"))

- (cxx:set-mapping signal-mapper button button)

-

- (qt:connect (qt:get-signal signal-mapper "mapped(QObject*)")

- #'(lambda (object)

- (5am:is (eq button object))

- (incf click-count)))

- (5am:is (= 0 click-count))

- (qt.test:test.mouse-click button qt:+left-button+)

- (5am:is (= 1 click-count)))))

+ (qt:with-app ()

+ (let ((button (make-instance 'qt:push-button))

+ (click-count 0)

+ (signal-mapper (make-instance 'qt:signal-mapper)))

+ (qt:connect (qt:get-signal button "clicked()")

+ (qt:get-slot signal-mapper "map()"))

+ (cxx:set-mapping signal-mapper button button)

+ ;; button is a QWidget thus it's mapped(QWidget*) and not

+ ;; mapped(QObject*)

+ (qt:connect (qt:get-signal signal-mapper "mapped(QWidget*)")

+ #'(lambda (object)

+ (5am:is (eq button object))

+ (incf click-count)))

+ (5am:is (= 0 click-count))

+ (qt:test.mouse-click button qt:+left-button+

+ 0 (make-instance 'qt:point) -1)

+ (5am:is (= 1 click-count)))))

(5am:test receive-by-value

"Receive a C++ class by value signal."

- (qt:with-app

+ (qt:with-app ()

(let ((model (make-instance 'qt:string-list-model))

(count 0))

(qt:connect (qt:get-signal model

"rowsInserted(QModelIndex, int, int)")

#'(lambda (parent start end)

- (declare (ignore end))

+ (declare (ignore end))

(5am:is (cxx:= (cxx:parent (cxx:index model start)))

- parent)

+ parent)

(incf count)))

(5am:is (= 0 count))

(cxx:insert-rows model 0 1)

@@ -182,13 +183,13 @@

(5am:test (emit-user-conversion :depends-on emit-qstring-signal)

"Emit a signal with a user conversion of the argument."

- (qt:with-app

- (let ((combobox (make-instance 'qt:text-edit))

- (set-font (qt:make-signal)))

- (qt:connect set-font

- (qt:get-slot combobox "setCurrentFont(QFont)"))

- (5am:is (cxx:operator== (cxx:current-font combobox)

- (make-instance 'qt:font)))

- (funcall set-font "Times")

- (5am:is (cxx:operator== (cxx:current-font combobox)

- "Times")))))

+ (qt:with-app ()

+ (let ((combobox (make-instance 'qt:text-edit))

+ (set-font (qt:make-signal)))

+ (qt:connect set-font

+ (qt:get-slot combobox "setCurrentFont(QFont)"))

+ (5am:is (cxx:operator== (cxx:current-font combobox)

+ (make-instance 'qt:font)))

+ (funcall set-font "Times")

+ (5am:is (cxx:operator== (cxx:current-font combobox)

+ "Times")))))

--- old-qt.tests/src/undo.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/undo.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -4,10 +4,9 @@

(defclass reversible-incf (qt:undo-command)

((place :accessor place

- :initarg :place))

+ :initarg :place))

(:metaclass cxx:class))

-

(defmethod cxx:redo ((incf reversible-incf))

(incf (symbol-value (place incf))))

@@ -15,20 +14,20 @@

(decf (symbol-value (place incf))))

(5am:test undo-stack

- "Test ownership transfer of a undo-command to the undo-stack."

- (let ((undo-stack (make-instance 'qt:undo-stack))

- (iterations 10)

- (counter 0))

- (declare (special counter))

- (dotimes (i iterations)

- (cxx:push undo-stack

- (make-instance 'reversible-incf :place 'counter))

- (gc :full t)) ;; Test for faulty ownership transfer

- (5am:is (eq t (cxx:can-undo undo-stack)))

- (5am:is (= iterations counter))

-

- (dotimes (i iterations)

- (cxx:undo undo-stack))

- (5am:is (eq nil (cxx:can-undo undo-stack)))

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

+ "Test ownership transfer of a undo-command to the undo-stack."

+ (let ((undo-stack (make-instance 'qt:undo-stack))

+ (iterations 10)

+ (counter 0))

+ (declare (special counter))

+ (dotimes (i iterations)

+ (cxx:push undo-stack

+ (make-instance 'reversible-incf :place 'counter))

+ (gc :full t)) ;; Test for faulty ownership transfer

+ (5am:is (eq t (cxx:can-undo undo-stack)))

+ (5am:is (= iterations counter))

+

+ (dotimes (i iterations)

+ (cxx:undo undo-stack))

+ (5am:is (eq nil (cxx:can-undo undo-stack)))

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

--- old-qt.tests/src/variant.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/src/variant.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -4,9 +4,9 @@

(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-string)))

(5am:for-all ((string (5am:gen-one-element "foo"

- "Foo Bar")))

+ "Foo Bar")))

(5am:is (eq t (cxx:= string (qt:make-variant string))))

(5am:is (string= string (qt:value (qt:make-variant string))))))

@@ -39,3 +39,23 @@

(let ((variant (qt:make-variant)))

(5am:is (= 1 (setf (qt:value variant) 1)))

(5am:is (= 1 (qt:value variant)))))

+

+(5am:test variant-list

+ (let ((list (qt:make-variant (map 'vector #'qt:make-variant

+ '(1 "asdf" #\a)))))

+ (5am:is (string= "QVariantList"

+ (cxx:type-name list)))))

+

+(5am:test exact-int-type-match

+ "Test overload resolution exact match long vs. int."

+ (5am:is (enum= qt:variant.+uint+

+ (cxx:type (qt:make-variant 1))))

+ (5am:is (enum= qt:variant.+int+

+ (cxx:type (qt:make-variant -1)))))

+ ;; on 32 bit sizeof(long) == sizeof(int) thus not test for that.

+

+(5am:test variant-color

+ "Test QColor variant."

+ (let ((color (make-instance 'qt:color :arg0 qt:+green+)))

+ (5am:is (string= (cxx:name color)

+ (cxx:name (qt:value (qt:make-variant color)))))))

--- old-qt.tests/test.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/test.lisp 2014-10-30 07:56:41.000000000 +0100

@@ -1,25 +1,9 @@

#|

exec -a "$0" sbcl --noinform --noprint --disable-debugger --load $0 --end-toplevel-options "$@"

-# do not use --script to allow loading mudballs with ${HOME}/.sbclrc

# Used for testing on darcs record.

|#

-

-(in-package :sysdef-user)

-

-(defun load-sysdef (pathname system)

- (load pathname)

- (setf (mb.sysdef::pathname-of (find-system system)) pathname))

-

-(defun load-sysdef-file (system-name)

- "Loads a mbd file in the current directory."

- (load-sysdef (make-pathname :defaults *default-pathname-defaults*

- :name (string-downcase system-name)

- :type "mbd")

- system-name))

-

-(load-sysdef-file :qt.tests)

-(mb:clean :qt.tests)

-(mb:test :qt.tests)

+(asdf:operate 'asdf:load-op :cl-smoke.qt.tests)

+(asdf:operate 'asdf:test-op :cl-smoke.qt.tests)

(sb-ext:quit)

--- old-qt.tests/tests/test.lisp 2014-10-30 07:56:41.000000000 +0100

+++ new-qt.tests/tests/test.lisp 1970-01-01 01:00:00.000000000 +0100

@@ -1,3 +0,0 @@

-(in-package :qt.tests)

-

-(run)