diff options
Diffstat (limited to 'tests/async.test')
| -rw-r--r-- | tests/async.test | 148 |
1 files changed, 109 insertions, 39 deletions
diff --git a/tests/async.test b/tests/async.test index b0582fc..b369839 100644 --- a/tests/async.test +++ b/tests/async.test @@ -16,12 +16,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } -if {[info commands testasync] == {}} { - puts "This application hasn't been compiled with the \"testasync\"" - puts "command, so I can't test Tcl_AsyncCreate et al." - ::tcltest::cleanupTests - return -} +testConstraint testasync [llength [info commands testasync]] +testConstraint threaded [expr { + [info exists ::tcl_platform(threaded)] && $::tcl_platform(threaded) +}] proc async1 {result code} { global aresult acode @@ -40,55 +38,68 @@ proc async3 {result code} { set aresult "test pattern" return -code $code $result } +proc \# {result code} { + global aresult acode + set aresult $result + set acode $code + return "comment quoting" +} -set handler1 [testasync create async1] -set handler2 [testasync create async2] -set handler3 [testasync create async3] -test async-1.1 {basic async handlers} { +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} { +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} { +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} { +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} { +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} { +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 } -set hm1 [testasync create mult1] proc mult2 {result code} { global x lappend x mult2 return -code 9 mult2 } -set hm2 [testasync create mult2] proc mult3 {result code} { global x hm1 hm2 lappend x [catch {testasync mark $hm2 serial2 0}] @@ -96,9 +107,12 @@ proc mult3 {result code} { lappend x mult3 return -code 11 mult3 } -set hm3 [testasync create mult3] - -test async-2.1 {multiple handlers} { +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}} @@ -119,31 +133,87 @@ proc del2 {result code} { lappend x del2 return -code 3 del2 } -testasync delete $handler1 -testasync delete $hm2 -testasync delete $hm3 -set hm2 [testasync create del1] -set hm3 [testasync create mult2] -set hm4 [testasync create 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} { +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}} +proc nothing {} { + # empty proc +} +proc hang1 {handle} { + global aresult + set aresult {Async event not delivered} + testasync marklater $handle + for {set i 0} { + $i < 2500000 && $aresult eq "Async event not delivered" + } {incr i} { + nothing + } + return $aresult +} +proc hang2 {handle} { + global aresult + set aresult {Async event not delivered} + testasync marklater $handle + for {set i 0} { + $i < 2500000 && $aresult eq "Async event not delivered" + } {incr i} {} + return $aresult +} +proc hang3 {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 +}] + +test async-4.1 {async interrupting bytecode sequence} -constraints { + testasync threaded +} -setup { + set hm [testasync create async3] +} -body { + hang1 $hm +} -result {test pattern} -cleanup { + testasync delete $hm +} +test async-4.2 {async interrupting straight bytecode sequence} -constraints { + testasync threaded +} -setup { + set hm [testasync create async3] +} -body { + hang2 $hm +} -result {test pattern} -cleanup { + testasync delete $hm +} +test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { + testasync threaded +} -setup { + set hm [testasync create async3] +} -body { + hang3 $hm +} -result {test pattern} -cleanup { + testasync delete $hm +} + # cleanup -testasync delete +if {[testConstraint testasync]} { + testasync delete +} ::tcltest::cleanupTests return - - - - - - - - - - - +# Local Variables: +# mode: tcl +# End: |