summaryrefslogtreecommitdiffstats
path: root/tcl8.6/tests/async.test
blob: e7fc45a4469e1c7a239c6d19ebf1c571f69ffccb (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
# Commands covered:  none
#
# This file contains a collection of tests for Tcl_AsyncCreate and related
# library procedures.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testasync [llength [info commands testasync]]
testConstraint threaded [::tcl::pkgconfig get threaded]

proc async1 {result code} {
    global aresult acode
    set aresult $result
    set acode $code
    return "new result"
}
proc async2 {result code} {
    global aresult acode
    set aresult $result
    set acode $code
    return -code error "xyzzy"
}
proc async3 {result code} {
    global aresult
    set aresult "test pattern"
    return -code $code $result
}
proc \# {result code} {
    global aresult acode
    set aresult $result
    set acode $code
    return "comment quoting"
}

if {[testConstraint testasync]} {
    set handler1 [testasync create async1]
    set handler2 [testasync create async2]
    set handler3 [testasync create async3]
    set handler4 [testasync create \#]
}
test async-1.1 {basic async handlers} testasync {
    set aresult xxx
    set acode yyy
    list [catch {testasync mark $handler1 "original" 0} msg] $msg \
	   $acode $aresult
} {0 {new result} 0 original}
test async-1.2 {basic async handlers} testasync {
    set aresult xxx
    set acode yyy
    list [catch {testasync mark $handler1 "original" 1} msg] $msg \
	   $acode $aresult
} {0 {new result} 1 original}
test async-1.3 {basic async handlers} testasync {
    set aresult xxx
    set acode yyy
    list [catch {testasync mark $handler2 "old" 0} msg] $msg \
	   $acode $aresult
} {1 xyzzy 0 old}
test async-1.4 {basic async handlers} testasync {
    set aresult xxx
    set acode yyy
    list [catch {testasync mark $handler2 "old" 3} msg] $msg \
	   $acode $aresult
} {1 xyzzy 3 old}
test async-1.5 {basic async handlers} testasync {
    set aresult xxx
    list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult
} {0 foobar {test pattern}}
test async-1.6 {basic async handlers} testasync {
    set aresult xxx
    list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult
} {1 foobar {test pattern}}
test async-1.7 {basic async handlers} testasync {
    set aresult xxx
    set acode yyy
    list [catch {testasync mark $handler4 "original" 0} msg] $msg \
	   $acode $aresult
} {0 {comment quoting} 0 original}

proc mult1 {result code} {
    global x
    lappend x mult1
    return -code 7 mult1
}
proc mult2 {result code} {
    global x
    lappend x mult2
    return -code 9 mult2
}
proc mult3 {result code} {
    global x hm1 hm2
    lappend x [catch {testasync mark $hm2 serial2 0}]
    lappend x [catch {testasync mark $hm1 serial1 0}]
    lappend x mult3
    return -code 11 mult3
}
if {[testConstraint testasync]} {
    set hm1 [testasync create mult1]
    set hm2 [testasync create mult2]
    set hm3 [testasync create mult3]
}
test async-2.1 {multiple handlers} testasync {
    set x {}
    list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x
} {9 mult2 {0 0 mult3 mult1 mult2}}

proc del1 {result code} {
    global x hm1 hm2 hm3 hm4
    lappend x [catch {testasync mark $hm3 serial2 0}]
    lappend x [catch {testasync mark $hm1 serial1 0}]
    lappend x [catch {testasync mark $hm4 serial1 0}]
    testasync delete $hm1
    testasync delete $hm2
    testasync delete $hm3
    lappend x del1
    return -code 13 del1
}
proc del2 {result code} {
    global x
    lappend x del2
    return -code 3 del2
}
if {[testConstraint testasync]} {
    testasync delete $handler1
    testasync delete $hm2
    testasync delete $hm3
    set hm2 [testasync create del1]
    set hm3 [testasync create mult2]
    set hm4 [testasync create del2]
}

test async-3.1 {deleting handlers} testasync {
    set x {}
    list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}

test async-4.1 {async interrupting bytecode sequence} -constraints {
    testasync threaded
} -setup {
    set hm [testasync create async3]
    proc nothing {} {
	# empty proc
    }
} -body {
    apply {{handle} {
    global aresult
    set aresult {Async event not delivered}
    testasync marklater $handle
    # allow plenty of time to pass in case valgrind is running
    set start [clock seconds]
    while {
	[clock seconds] - $start < 180 && $aresult eq "Async event not delivered"
    } {
	# be less busy
	after 100
	nothing
    }
	return $aresult
    }} $hm
} -result {test pattern} -cleanup {
    # give other threads some time to go way so that valgrind doesn't pick up
    # "still reachable" cases from early thread termination
    after 100
    testasync delete $hm
}
test async-4.2 {async interrupting straight bytecode sequence} -constraints {
    testasync threaded
} -setup {
    set hm [testasync create async3]
} -body {
    apply {{handle} {
	global aresult
	set aresult {Async event not delivered}
	testasync marklater $handle
	# allow plenty of time to pass in case valgrind is running
	set start [clock seconds]
	while {
		[clock seconds] - $start < 180 && $aresult eq "Async event not delivered"
	} {
		# be less busy
	    after 100
	}
	return $aresult
    }} $hm
} -result {test pattern} -cleanup {
    # give other threads some time to go way so that valgrind doesn't pick up
    # "still reachable" cases from early thread termination
    after 100
    testasync delete $hm
}
test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
    testasync threaded
} -setup {
    set hm [testasync create async3]
} -body {
    apply [list {handle} [concat {
	global aresult
	set aresult {Async event not delivered}
	testasync marklater $handle
	set i 0
    } "[string repeat {;incr i;} 1500000]after 10;" {
	return $aresult
    }]] $hm
} -result {test pattern} -cleanup {
    # give other threads some time to go way so that valgrind doesn't pick up
    # "still reachable" cases from early thread termination
    after 100
    testasync delete $hm
}

# cleanup
if {[testConstraint testasync]} {
    testasync delete
}
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End: