diff options
author | dkf <dkf@noemail.net> | 2003-11-16 00:49:19 (GMT) |
---|---|---|
committer | dkf <dkf@noemail.net> | 2003-11-16 00:49:19 (GMT) |
commit | 1c9a4b78ff036b30a9595129b119add3ee246f2c (patch) | |
tree | 0ca93a479ec4c1eb68a2482ff755d5591112baeb /tests/async.test | |
parent | 6decc1455909d6c1c48cec17c9d37976da27ab74 (diff) | |
download | tcl-1c9a4b78ff036b30a9595129b119add3ee246f2c.zip tcl-1c9a4b78ff036b30a9595129b119add3ee246f2c.tar.gz tcl-1c9a4b78ff036b30a9595129b119add3ee246f2c.tar.bz2 |
Miguel Sofer's patch (with small revisions) to make sure the bytecode engine
checks for async events fairly frequently. [Bug 746722]
FossilOrigin-Name: b8a0c26a583d99e28baeef2a94d4925ec7f69f8e
Diffstat (limited to 'tests/async.test')
-rw-r--r-- | tests/async.test | 80 |
1 files changed, 68 insertions, 12 deletions
diff --git a/tests/async.test b/tests/async.test index af63413..863be98 100644 --- a/tests/async.test +++ b/tests/async.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: async.test,v 1.6 2003/07/24 16:05:24 dgp Exp $ +# RCS: @(#) $Id: async.test,v 1.7 2003/11/16 00:49:20 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -25,6 +25,10 @@ if {[info commands testasync] == {}} { return } +tcltest::testConstraint threaded [expr { + [info exists ::tcl_platform(threaded)] && $::tcl_platform(threaded) +}] + proc async1 {result code} { global aresult acode set aresult $result @@ -146,19 +150,71 @@ test async-3.1 {deleting handlers} { 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] { + return $aresult +}] + +test async-4.1 {async interrupting bytecode sequence} -constraints { + 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 { + 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 { + threaded +} -setup { + set hm [testasync create async3] +} -body { + hang3 $hm +} -result {test pattern} -cleanup { + testasync delete $hm +} + # cleanup testasync delete ::tcltest::cleanupTests return - - - - - - - - - - - +# Local Variables: +# mode: tcl +# End: |