repos
/
qt.tests
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Support ASDF instead of Mudballs.
Annotate for file /src/abort.lisp
2009-06-03 tobias
1
(in-package :qt.tests)
22:07:20 '
2
'
3
(5am:in-suite :qt.suite)
'
4
'
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)
2009-07-01 tobias
8
`(handler-bind ((,condition #'(lambda (,c)
11:02:20 '
9
(declare (ignore ,c))
'
10
(assert (find-restart ',restart))
'
11
,(when handler `(funcall ,handler))
'
12
(invoke-restart ',restart))))
'
13
,@body)))
2009-06-03 tobias
14
22:07:20 '
15
(define-condition no-ticket (error) ())
'
16
'
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)))
'
21
'
22
(5am:test abort-with-app
'
23
"Test aborting the event loop."
'
24
(dotimes (i 3)
'
25
(bt:with-timeout (5)
2009-07-01 tobias
26
(with-invoke-restart (no-ticket qt::abort-app)
11:02:20 '
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))))))))
2009-06-03 tobias
38
22:07:20 '
39
(defclass error-object (qt:object)
'
40
()
'
41
(:metaclass cxx:class))
'
42
'
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)))
'
46
'
47
(5am:test error-in-callback-return
2009-07-01 tobias
48
"Test returning from a void method on error."
11:02:20 '
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)))))
2009-06-03 tobias
57
22:07:20 '
58
(5am:test error-in-callback-default
'
59
"Test calling the default C++ method on error in the user defined method."
2009-07-01 tobias
60
(qt:with-core-app ()
11:02:20 '
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)))))
2009-06-03 tobias
68
22:07:20 '
69
(5am:test error-in-slot
'
70
"Test skipping a slot function when it signals an error."
2009-07-01 tobias
71
(qt:with-core-app ()
2009-06-03 tobias
72
(let ((timer (make-instance 'qt:timer))
22:07:20 '
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)))))
2009-12-13 tobias
83
12:45:36 '
84
(5am:test msg-handler
'
85
"Test catching Q_ASSERTS."
'
86
(5am:signals error
'
87
(qt:qt-assert ":qt.tests msg-handler test assert"
'
88
"abort.lisp"
'
89
-1)))
'
90