1# Commands covered:  none
2#
3# This file contains a collection of tests for Tcl_AsyncCreate and related
4# library procedures.  Sourcing this file into Tcl runs the tests and
5# generates output for errors.  No output means no errors were found.
6#
7# Copyright © 1993 The Regents of the University of California.
8# Copyright © 1994-1996 Sun Microsystems, Inc.
9# Copyright © 1998-1999 Scriptics Corporation.
10#
11# See the file "license.terms" for information on usage and redistribution
12# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13
14if {"::tcltest" ni [namespace children]} {
15    package require tcltest 2.5
16    namespace import -force ::tcltest::*
17}
18
19::tcltest::loadTestedCommands
20catch [list package require -exact tcl::test [info patchlevel]]
21
22testConstraint testasync [llength [info commands testasync]]
23testConstraint knownMsvcBug [expr {![info exists ::env(CI_BUILD_WITH_MSVC)]}]
24
25proc async1 {result code} {
26    global aresult acode
27    set aresult $result
28    set acode $code
29    return "new result"
30}
31proc async2 {result code} {
32    global aresult acode
33    set aresult $result
34    set acode $code
35    return -code error "xyzzy"
36}
37proc async3 {result code} {
38    global aresult
39    set aresult "test pattern"
40    return -code $code $result
41}
42proc \# {result code} {
43    global aresult acode
44    set aresult $result
45    set acode $code
46    return "comment quoting"
47}
48
49if {[testConstraint testasync]} {
50    set handler1 [testasync create async1]
51    set handler2 [testasync create async2]
52    set handler3 [testasync create async3]
53    set handler4 [testasync create \#]
54}
55test async-1.1 {basic async handlers} testasync {
56    set aresult xxx
57    set acode yyy
58    list [catch {testasync mark $handler1 "original" 0} msg] $msg \
59	   $acode $aresult
60} {0 {new result} 0 original}
61test async-1.2 {basic async handlers} testasync {
62    set aresult xxx
63    set acode yyy
64    list [catch {testasync mark $handler1 "original" 1} msg] $msg \
65	   $acode $aresult
66} {0 {new result} 1 original}
67test async-1.3 {basic async handlers} testasync {
68    set aresult xxx
69    set acode yyy
70    list [catch {testasync mark $handler2 "old" 0} msg] $msg \
71	   $acode $aresult
72} {1 xyzzy 0 old}
73test async-1.4 {basic async handlers} testasync {
74    set aresult xxx
75    set acode yyy
76    list [catch {testasync mark $handler2 "old" 3} msg] $msg \
77	   $acode $aresult
78} {1 xyzzy 3 old}
79test async-1.5 {basic async handlers} testasync {
80    set aresult xxx
81    list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult
82} {0 foobar {test pattern}}
83test async-1.6 {basic async handlers} testasync {
84    set aresult xxx
85    list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult
86} {1 foobar {test pattern}}
87test async-1.7 {basic async handlers} testasync {
88    set aresult xxx
89    set acode yyy
90    list [catch {testasync mark $handler4 "original" 0} msg] $msg \
91	   $acode $aresult
92} {0 {comment quoting} 0 original}
93
94proc mult1 {result code} {
95    global x
96    lappend x mult1
97    return -code 7 mult1
98}
99proc mult2 {result code} {
100    global x
101    lappend x mult2
102    return -code 9 mult2
103}
104proc mult3 {result code} {
105    global x hm1 hm2
106    lappend x [catch {testasync mark $hm2 serial2 0}]
107    lappend x [catch {testasync mark $hm1 serial1 0}]
108    lappend x mult3
109    return -code 11 mult3
110}
111if {[testConstraint testasync]} {
112    set hm1 [testasync create mult1]
113    set hm2 [testasync create mult2]
114    set hm3 [testasync create mult3]
115}
116test async-2.1 {multiple handlers} testasync {
117    set x {}
118    list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x
119} {9 mult2 {0 0 mult3 mult1 mult2}}
120
121proc del1 {result code} {
122    global x hm1 hm2 hm3 hm4
123    lappend x [catch {testasync mark $hm3 serial2 0}]
124    lappend x [catch {testasync mark $hm1 serial1 0}]
125    lappend x [catch {testasync mark $hm4 serial1 0}]
126    testasync delete $hm1
127    testasync delete $hm2
128    testasync delete $hm3
129    lappend x del1
130    return -code 13 del1
131}
132proc del2 {result code} {
133    global x
134    lappend x del2
135    return -code 3 del2
136}
137if {[testConstraint testasync]} {
138    testasync delete $handler1
139    testasync delete $hm2
140    testasync delete $hm3
141    set hm2 [testasync create del1]
142    set hm3 [testasync create mult2]
143    set hm4 [testasync create del2]
144}
145
146test async-3.1 {deleting handlers} testasync {
147    set x {}
148    list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
149} {3 del2 {0 0 0 del1 del2}}
150
151test async-4.1 {async interrupting bytecode sequence} -constraints {
152    testasync
153} -setup {
154    set hm [testasync create async3]
155    proc nothing {} {
156	# empty proc
157    }
158} -body {
159    apply {{handle} {
160    global aresult
161    set aresult {Async event not delivered}
162    testasync marklater $handle
163    # allow plenty of time to pass in case valgrind is running
164    set start [clock seconds]
165    while {
166	[clock seconds] - $start < 180 && $aresult eq "Async event not delivered"
167    } {
168	# be less busy
169	after 100
170	nothing
171    }
172	return $aresult
173    }} $hm
174} -result {test pattern} -cleanup {
175    # give other threads some time to go way so that valgrind doesn't pick up
176    # "still reachable" cases from early thread termination
177    after 100
178    testasync delete $hm
179}
180test async-4.2 {async interrupting straight bytecode sequence} -constraints {
181    testasync
182} -setup {
183    set hm [testasync create async3]
184} -body {
185    apply {{handle} {
186	global aresult
187	set aresult {Async event not delivered}
188	testasync marklater $handle
189	# allow plenty of time to pass in case valgrind is running
190	set start [clock seconds]
191	while {
192		[clock seconds] - $start < 180 && $aresult eq "Async event not delivered"
193	} {
194		# be less busy
195	    after 100
196	}
197	return $aresult
198    }} $hm
199} -result {test pattern} -cleanup {
200    # give other threads some time to go way so that valgrind doesn't pick up
201    # "still reachable" cases from early thread termination
202    after 100
203    testasync delete $hm
204}
205test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
206    testasync knownMsvcBug
207} -setup {
208    set hm [testasync create async3]
209} -body {
210    apply [list {handle} [concat {
211	global aresult
212	set aresult {Async event not delivered}
213	testasync marklater $handle
214	set i 0
215    } "[string repeat {;incr i;} 1500000]after 10;" {
216	return $aresult
217    }]] $hm
218} -result {test pattern} -cleanup {
219    # give other threads some time to go way so that valgrind doesn't pick up
220    # "still reachable" cases from early thread termination
221    after 100
222    testasync delete $hm
223}
224
225# cleanup
226if {[testConstraint testasync]} {
227    testasync delete
228}
229::tcltest::cleanupTests
230return
231
232# Local Variables:
233# mode: tcl
234# End:
235