darcs - qt.tests

1 (in-package :qt.tests)

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

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

6 "Invokes RESTART when CONDITION is signaled in BODY."

7 (alexandria:with-gensyms (c)

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

9 (declare (ignore ,c))

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

11 ,(when handler `(funcall ,handler))

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

13 ,@body)))

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

17 (defun call-slot (slot &rest arguments)

18 (let ((sig (qt:make-signal)))

19 (qt:connect sig slot qt:+queued-connection+)

20 (apply sig arguments)))

22 (5am:test abort-with-app

23 "Test aborting the event loop."

24 (dotimes (i 3)

25 (bt:with-timeout (5)

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

27 (qt:with-app ()

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

29 (continued-p))

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

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

32 #'(lambda ()

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

34 (setf continued-p t)))

35 (cxx:start timer 0)

36 (qt:exec)

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

39 (defclass error-object (qt:object)

40 ()

41 (:metaclass cxx:class))

43 (defmethod cxx:timer-event ((object error-object) timer-event)

44 (cxx:kill-timer object (cxx:timer-id timer-event))

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

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

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

49 (qt:with-core-app ()

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

51 (restarted-p))

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

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

54 (cxx:start-timer object 0)

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

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

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

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

60 (qt:with-core-app ()

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

62 (restarted-p))

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

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

65 (cxx:start-timer object 0)

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

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

69 (5am:test error-in-slot

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

71 (qt:with-core-app ()

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

73 (continued-p))

74 (with-invoke-restart (no-ticket continue

75 #'(lambda () (setf continued-p t)))

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

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

78 #'(lambda ()

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

80 (cxx:start timer 0)

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

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

85 (5am:test msg-handler

86 "Test catching Q_ASSERTS."

87 (5am:signals error

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

89 "abort.lisp"

90 -1)))