Thu Jun 4 00:07:20 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Test restarts in callback and slot; and test abort-app
hunk ./qt.tests.mbd 25
+ ("abort" (:needs "tests"))
addfile ./src/abort.lisp
hunk ./src/abort.lisp 1
+(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 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)))))
+
+(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)))))
hunk ./src/signal-slot.lisp 169
+ (declare (ignore end))