Sat Apr 3 21:13:24 CEST 2010 Tobias Rautenkranz * Test static member variable access using slot-value with a class object. Sat Apr 3 14:52:50 CEST 2010 Tobias Rautenkranz * Test slot-value for C++ attributes. Sat Apr 3 14:50:36 CEST 2010 Tobias Rautenkranz * Test qt.opengl conversions. Sat Feb 20 22:06:45 CET 2010 Tobias Rautenkranz * Test (qt:value (qt:make-variant qt:+green+)) Sat Feb 20 19:06:27 CET 2010 Tobias Rautenkranz * Test overload resolution exact match for long and ulong. Mon Jan 25 22:13:40 CET 2010 Tobias Rautenkranz * Test QGraphicsScene::setItem Mon Jan 25 19:51:13 CET 2010 Tobias Rautenkranz * Test QList translation Sat Jan 23 23:18:13 CET 2010 Tobias Rautenkranz * Test to QVector translation. Sun Jan 10 09:57:03 CET 2010 Tobias Rautenkranz * ASDF & modular smoke. Sun Dec 13 13:45:36 CET 2009 Tobias Rautenkranz * Support ASDF instead of Mudballs. Wed Sep 2 14:02:23 CEST 2009 Tobias Rautenkranz * Test Lisp to QList and test user conversion sequence for return values. Sun Aug 30 16:18:04 CEST 2009 Tobias Rautenkranz * Test multiple C++ superclasses. Thu Aug 27 10:41:11 CEST 2009 Tobias Rautenkranz * 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 * Qt property names are symbols in the keyword package. Wed Jul 1 13:02:20 CEST 2009 Tobias Rautenkranz * Use new qt:with-app Wed Jul 1 00:48:36 CEST 2009 Tobias Rautenkranz * CCL fixes Sun Jun 21 11:21:04 CEST 2009 Tobias Rautenkranz * uses-macros-from :smoke Thu Jun 11 20:52:38 CEST 2009 Tobias Rautenkranz * The Qt modules are now all in :qt Thu Jun 11 17:04:11 CEST 2009 Tobias Rautenkranz * Test adding a child to a no smoke object and fixes for :qt :qt-impl split. Wed Jun 10 14:09:14 CEST 2009 Tobias Rautenkranz * Test gc cycle and non cxx:object parent Fri Jun 5 09:52:01 CEST 2009 Tobias Rautenkranz * Test #'QT:GET-SLOT for function with this argument. Fri Jun 5 09:49:09 CEST 2009 Tobias Rautenkranz * Fix test failures when a qt:application instance is already running. Thu Jun 4 00:07:20 CEST 2009 Tobias Rautenkranz * Test restarts in callback and slot; and test abort-app Mon Jun 1 00:56:59 CEST 2009 Tobias Rautenkranz * Fix timer test Mon Jun 1 00:41:10 CEST 2009 Tobias Rautenkranz * Test QList to sequence conversion. Mon Jun 1 00:26:27 CEST 2009 Tobias Rautenkranz * Test QList to sequence conversion. Mon Jun 1 00:24:46 CEST 2009 Tobias Rautenkranz * Test undo stack Sun May 31 19:37:47 CEST 2009 Tobias Rautenkranz * Test return QVariant on the stack Sun May 31 19:36:58 CEST 2009 Tobias Rautenkranz * Test remove-property Sun May 31 19:36:36 CEST 2009 Tobias Rautenkranz * use cxx:class instead of smoke-wrapper-class diff -rN -u old-qt.tests/cl-smoke.qt.tests.asd new-qt.tests/cl-smoke.qt.tests.asd --- 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-11-19 23:10:30.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)))) diff -rN -u old-qt.tests/qt.tests.mbd new-qt.tests/qt.tests.mbd --- old-qt.tests/qt.tests.mbd 2014-11-19 23:10:30.000000000 +0100 +++ new-qt.tests/qt.tests.mbd 1970-01-01 01:00:00.000000000 +0100 @@ -1,26 +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")) - ("thread" (:needs "tests")) - ("properties" (:needs "tests")) - ("click" (:needs "tests")))))) diff -rN -u old-qt.tests/src/abort.lisp new-qt.tests/src/abort.lisp --- old-qt.tests/src/abort.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-qt.tests/src/abort.lisp 2014-11-19 23:10:30.000000000 +0100 @@ -0,0 +1,90 @@ +(in-package :qt.tests) + +(5am:in-suite :qt.suite) + +(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))) + +(define-condition no-ticket (error) ()) + +(defun call-slot (slot &rest arguments) + (let ((sig (qt:make-signal))) + (qt:connect sig slot qt:+queued-connection+) + (apply sig arguments))) + +(5am:test abort-with-app + "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)))))))) + +(defclass error-object (qt:object) + () + (:metaclass cxx:class)) + +(defmethod cxx:timer-event ((object error-object) timer-event) + (cxx:kill-timer object (cxx:timer-id timer-event)) + (error (make-condition 'no-ticket))) + +(5am:test error-in-callback-return + "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))))) + + (5am:test error-in-slot + "Test skipping a slot function when it signals an error." + (qt:with-core-app () + (let ((timer (make-instance 'qt:timer)) + (continued-p)) + (with-invoke-restart (no-ticket continue + #'(lambda () (setf continued-p t))) + (cxx:set-single-shot timer t) + (qt:connect (qt:get-signal timer "timeout()") + #'(lambda () + (error (make-condition 'no-ticket)))) + (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))) diff -rN -u old-qt.tests/src/application.lisp new-qt.tests/src/application.lisp --- old-qt.tests/src/application.lisp 2014-11-19 23:10:30.000000000 +0100 +++ new-qt.tests/src/application.lisp 2014-11-19 23:10:30.000000000 +0100 @@ -4,24 +4,35 @@ (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))) - (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"))) - (5am:is (eql nil (qt:app-p))))) + (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 (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))))))) diff -rN -u old-qt.tests/src/click.lisp new-qt.tests/src/click.lisp --- old-qt.tests/src/click.lisp 2014-11-19 23:10:30.000000000 +0100 +++ new-qt.tests/src/click.lisp 2014-11-19 23:10:30.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,10 +37,28 @@ (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 () + (let ((widget (make-instance 'click-test-widget)) + (click-count 0)) + (qt:connect (qt:get-signal widget "clicked(bool)") + (qt:get-slot widget + #'(lambda (object checked) + (5am:is (eq nil checked)) + (5am:is (eq widget object)) + (incf click-count)))) + (5am:is (= 0 click-count)) + (qt:test.mouse-click widget qt:+left-button+ + 0 (make-instance 'qt:point) -1) + (5am:is (= 1 click-count)) + (qt:test.mouse-click widget qt:+left-button+ + 0 (make-instance 'qt:point) -1) + (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 2014-11-19 23:10:30.000000000 +0100 +++ new-qt.tests/src/gc.lisp 2014-11-19 23:10:30.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,9 +37,13 @@ "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 smoke::smoke-wrapper-class)) + (:metaclass cxx:class)) ;; FIXME 5am prevents garbage collection!? ;; use eval !? @@ -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))) @@ -58,7 +60,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))) @@ -67,22 +68,119 @@ (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*))))) + (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 ;) (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 () + (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 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 (>= (+ 2 objects) (hash-table-count smoke::*object-map*)))))) + +(5am:test (ownership-transfer-no-wrapper :depends-on gc-lisp-child) + "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)))) + (setf (cxx:object-name parent) "parent" + (cxx:object-name object) "child")) + (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))))))) + +(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 :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)))) + +|# diff -rN -u old-qt.tests/src/graphics-item.lisp new-qt.tests/src/graphics-item.lisp --- old-qt.tests/src/graphics-item.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-qt.tests/src/graphics-item.lisp 2014-11-19 23:10:30.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)))) diff -rN -u old-qt.tests/src/object.lisp new-qt.tests/src/object.lisp --- old-qt.tests/src/object.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-qt.tests/src/object.lisp 2014-11-19 23:10:30.000000000 +0100 @@ -0,0 +1,26 @@ +(in-package :qt.tests) + +(5am:in-suite :qt.suite) + +(5am:test test-children + "Test QList 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))))) diff -rN -u old-qt.tests/src/opengl.lisp new-qt.tests/src/opengl.lisp --- old-qt.tests/src/opengl.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-qt.tests/src/opengl.lisp 2014-11-19 23:10:30.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)))) diff -rN -u old-qt.tests/src/overload.lisp new-qt.tests/src/overload.lisp --- old-qt.tests/src/overload.lisp 2014-11-19 23:10:30.000000000 +0100 +++ new-qt.tests/src/overload.lisp 2014-11-19 23:10:30.000000000 +0100 @@ -4,18 +4,51 @@ (defclass my-object (qt:object) ((counter :accessor counter :initform 0)) - (:metaclass smoke::smoke-wrapper-class)) + (:metaclass cxx:class)) -(defmethod cxx:timer-event ((object my-object)) - (incf (counter object))) +(defmethod cxx:timer-event ((object my-object) event) + (incf (counter object)) + (cxx:quit (qt:app))) - -;;FIXME -#|(5am:test timer +(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))))) -|# + (qt:with-core-app () + (5am:is (= 0 (counter object))) + (cxx:start-timer object 0) + (with-timeout (5) + (qt:exec)) + (5am:is (= 1 (counter object)))))) + +(defclass my-list-model (qt:abstract-list-model) + ((counter :accessor counter :initform 0)) + (:metaclass cxx:class)) + +(defmethod cxx:data ((list my-list-model) index role) + (incf (counter list)) + (if (< (cxx:row index) 2) + (cxx:row index) ;; cl-smoke converts to the required qt:variant + (qt:make-variant))) + +(defmethod cxx:row-count ((list my-list-model) parent) + 2) + +(5am:test return-on-stack + "Test virtual method return value on stack." + (let ((list (make-instance 'my-list-model)) + (proxy (make-instance 'qt:sort-filter-proxy-model))) + (5am:is (= 0 (counter list))) + (setf (cxx:source-model proxy) list) + (dotimes (i 10) ;; test for faulty ownership transfer + (cxx:sort proxy 0) + (gc :full t)) + (5am:is (< 0 (counter list))))) + +(5am:test return-on-stack-c++ + (let ((list (make-instance + 'qt:string-list-model :args (list #("foo" "bar")))) + (proxy (make-instance 'qt:sort-filter-proxy-model))) + (setf (cxx:source-model proxy) list) + (dotimes (i 10) ;; test for faulty ownership transfer + (cxx:sort proxy 0) + (gc :full t)) + (5am:is (= 2 (cxx:row-count list))))) diff -rN -u old-qt.tests/src/package.lisp new-qt.tests/src/package.lisp --- old-qt.tests/src/package.lisp 2014-11-19 23:10:30.000000000 +0100 +++ new-qt.tests/src/package.lisp 2014-11-19 23:10:30.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)) diff -rN -u old-qt.tests/src/properties.lisp new-qt.tests/src/properties.lisp --- old-qt.tests/src/properties.lisp 2014-11-19 23:10:30.000000000 +0100 +++ new-qt.tests/src/properties.lisp 2014-11-19 23:10:30.000000000 +0100 @@ -5,17 +5,16 @@ (5am:test property-list "Test properties" (5am:is (= 1 (length (qt:class-properties (find-class 'qt:object))))) - (5am:is (= 1 (length (qt:properties (make-instance 'qt:object))))) - (5am:is (= 1 (length (qt:class-properties (find-class 'qt:qslot)))))) + (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))) + (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")) @@ -23,8 +22,11 @@ (setf (qt:property o 'foo) "bar") (5am:is (= 2 (length (qt:properties o)))) (5am:is (member 'foo (qt:properties o))) - (5am:is (eql t (qt:property-p o 'foo))) - (5am:is (string= (qt:property o 'foo) "bar")))) + (5am:is (eq t (qt:property-p o 'foo))) + (5am:is (string= (qt:property o 'foo) "bar")) + + (qt:remove-property o 'foo) + (5am:is (eq nil (qt:property-p o 'foo))))) (5am:test property-int @@ -33,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))))) diff -rN -u old-qt.tests/src/qbytearray.lisp new-qt.tests/src/qbytearray.lisp --- old-qt.tests/src/qbytearray.lisp 2014-11-19 23:10:30.000000000 +0100 +++ new-qt.tests/src/qbytearray.lisp 2014-11-19 23:10:30.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))))) diff -rN -u old-qt.tests/src/qlist.lisp new-qt.tests/src/qlist.lisp --- old-qt.tests/src/qlist.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-qt.tests/src/qlist.lisp 2014-11-19 23:10:30.000000000 +0100 @@ -0,0 +1,11 @@ +(in-package :qt.tests) + +(5am:in-suite :qt.suite) + +(5am:test variant-list + "QList" + (let ((variants (vector (qt:make-variant "foo")))) + (5am:is (every #'cxx:= + variants + (cxx:to-list (qt:make-variant variants)))))) + diff -rN -u old-qt.tests/src/qstring.lisp new-qt.tests/src/qstring.lisp --- old-qt.tests/src/qstring.lisp 2014-11-19 23:10:30.000000000 +0100 +++ new-qt.tests/src/qstring.lisp 2014-11-19 23:10:30.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)))))) diff -rN -u old-qt.tests/src/qvector.lisp new-qt.tests/src/qvector.lisp --- old-qt.tests/src/qvector.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-qt.tests/src/qvector.lisp 2014-11-19 23:10:30.000000000 +0100 @@ -0,0 +1,41 @@ +(in-package :qt.tests) + +(5am:in-suite :qt.suite) + +(5am:test qvector-qpoint + "Tests to QVector 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 + (tg:gc :full t)) + +(5am:test qvector-double + "Test QVector <-> 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 <-> 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))))) 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-11-19 23:10:30.000000000 +0100 +++ new-qt.tests/src/signal-slot.lisp 2014-11-19 23:10:30.000000000 +0100 @@ -1,22 +1,21 @@ (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)) + (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)")) @@ -93,7 +92,7 @@ "Pass a lisp object over a signal-slot connection." (let ((num 1d0) (count 0)) - (let ((my-signal (make-instance 'qt:qsignal)) + (let ((my-signal (qt:make-signal)) (my-slot (qt::make-slot #'(lambda (a b) (5am:is (eq a num)) (5am:is (eql t b)) @@ -113,6 +112,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 ccl) (5am:test (destroyed-signal :depends-on gc-qobject) "Receive a destroy signal for a QObject." (setf *destroyed* nil) @@ -123,51 +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)) (5am:is (cxx:= (cxx:parent (cxx:index model start))) - parent) + parent) (incf count))) (5am:is (= 0 count)) (cxx:insert-rows model 0 1) @@ -177,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"))))) diff -rN -u old-qt.tests/src/undo.lisp new-qt.tests/src/undo.lisp --- old-qt.tests/src/undo.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-qt.tests/src/undo.lisp 2014-11-19 23:10:30.000000000 +0100 @@ -0,0 +1,33 @@ +(in-package :qt.tests) + +(5am:in-suite :qt.suite) + +(defclass reversible-incf (qt:undo-command) + ((place :accessor place + :initarg :place)) + (:metaclass cxx:class)) + +(defmethod cxx:redo ((incf reversible-incf)) + (incf (symbol-value (place incf)))) + +(defmethod cxx:undo ((incf reversible-incf)) + (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)))) + diff -rN -u old-qt.tests/src/variant.lisp new-qt.tests/src/variant.lisp --- old-qt.tests/src/variant.lisp 2014-11-19 23:10:30.000000000 +0100 +++ new-qt.tests/src/variant.lisp 2014-11-19 23:10:30.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))))))) diff -rN -u old-qt.tests/test.lisp new-qt.tests/test.lisp --- old-qt.tests/test.lisp 2014-11-19 23:10:30.000000000 +0100 +++ new-qt.tests/test.lisp 2014-11-19 23:10:30.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) diff -rN -u old-qt.tests/tests/test.lisp new-qt.tests/tests/test.lisp --- old-qt.tests/tests/test.lisp 2014-11-19 23:10:30.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)