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