diff options
author | culler <culler> | 2020-08-10 12:49:19 (GMT) |
---|---|---|
committer | culler <culler> | 2020-08-10 12:49:19 (GMT) |
commit | 4f513496d8ee65a193392dbd2b0af0ed0da94539 (patch) | |
tree | 1d5d3626e9715b090845d06995db50af613e877b | |
parent | 35d0992797dc0bcdfae9edb823cb03c41bf37a5d (diff) | |
parent | 823d13656d0f81807f40c7029fcf4bf38215dedc (diff) | |
download | tcl-4f513496d8ee65a193392dbd2b0af0ed0da94539.zip tcl-4f513496d8ee65a193392dbd2b0af0ed0da94539.tar.gz tcl-4f513496d8ee65a193392dbd2b0af0ed0da94539.tar.bz2 |
Fix [f586089a2b]: removing the call to Tcl_ServiceAll from Tcl_WaitForEvent on macOS exposed race conditions in some io, chanio and event tests.
-rw-r--r-- | generic/tclTest.c | 52 | ||||
-rw-r--r-- | tests/chanio.test | 86 | ||||
-rw-r--r-- | tests/event.test | 9 | ||||
-rw-r--r-- | tests/io.test | 120 |
4 files changed, 187 insertions, 80 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c index 37aafd2..fde7190 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -307,7 +307,7 @@ static Tcl_FSNormalizePathProc TestReportNormalizePath; static Tcl_FSPathInFilesystemProc TestReportInFilesystem; static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep; static Tcl_FSDupInternalRepProc TestReportDupInternalRep; - +static Tcl_CmdProc TestServiceModeCmd; static Tcl_FSStatProc SimpleStat; static Tcl_FSAccessProc SimpleAccess; static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel; @@ -561,6 +561,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, + NULL, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, @@ -6049,6 +6051,54 @@ TestChannelEventCmd( /* *---------------------------------------------------------------------- * + * TestServiceModeCmd -- + * + * This procedure implements the "testservicemode" command which gets or + * sets the current Tcl ServiceMode. There are several tests which open + * a file and assign various handlers to it. For these tests to be + * deterministic it is important that file events not be processed until + * all of the handlers are in place. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May change the ServiceMode setting. + * + *---------------------------------------------------------------------- + */ + +static int +TestServiceModeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + int newmode, oldmode; + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?newmode?\"", NULL); + return TCL_ERROR; + } + oldmode = (Tcl_GetServiceMode() != TCL_SERVICE_NONE); + if (argc == 2) { + if (Tcl_GetInt(interp, argv[1], &newmode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newmode == 0) { + Tcl_SetServiceMode(TCL_SERVICE_NONE); + } else { + Tcl_SetServiceMode(TCL_SERVICE_ALL); + } + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(oldmode)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestWrongNumArgsObjCmd -- * * Test the Tcl_WrongNumArgs function. diff --git a/tests/chanio.test b/tests/chanio.test index 07a0d8d..bc6bb1b 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -5731,9 +5731,9 @@ test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileeven chan event $f readable {} }] } + set timer [after 10 lappend x timeout] testfevent cmd $script - after 1 ;# We must delay because Windows takes a little time to notice - update + vwait x testfevent cmd {chan close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} @@ -6375,7 +6375,7 @@ test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} -setup { test chan-io-50.1 {testing handler deletion} -setup { file delete $path(test1) -} -constraints {testchannelevent nonPortable} -body { +} -constraints testchannelevent -body { set f [open $path(test1) w] chan close $f set f [open $path(test1) r] @@ -6393,16 +6393,21 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] set z "" -} -constraints {testchannelevent nonPortable} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] +} -constraints testchannelevent -body { proc delhandler {f i} { variable z lappend z "called delhandler $f $i" testchannelevent $f delete 0 } - update + set z "" + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + vwait z + after cancel $timer string equal $z \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } -cleanup { @@ -6411,11 +6416,7 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] - set z "" -} -constraints {testchannelevent nonPortable} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] +} -constraints testchannelevent -body { proc notcalled {f i} { variable z lappend z "notcalled was called!! $f $i" @@ -6427,7 +6428,15 @@ test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { testchannelevent $f delete 0 lappend z "delhandler $f $i deleted myself" } - update + set z "" + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + vwait z + after cancel $timer string equal $z \ [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] @@ -6438,7 +6447,7 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent nonPortable} -body { +} -constraints testchannelevent -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code { if {$u eq "recursive"} { @@ -6452,19 +6461,20 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { }] variable u toplevel variable z "" - update + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer set z } -cleanup { chan close $f + update } -result {{delrecursive calling recursive} {delrecursive deleting recursive}} test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent nonPortable} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f]] - testchannelevent $f add readable [namespace code [list del $f]] + update +} -constraints testchannelevent -body { proc notcalled {f} { variable z lappend z "notcalled was called!! $f" @@ -6480,33 +6490,46 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { } else { set u recursive lappend z "del calling recursive" - update + set timer [after 50 lappend z timeout] + set mode [test servicemode 1] + vwait z + after cancel $timer + test servicemode $mode lappend z "del after update" } } set z "" set u toplevel - update + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f]] + testchannelevent $f add readable [namespace code [list del $f]] + testservicemode 1 + vwait z + after cancel $timer set z } -cleanup { chan close $f + update } -result [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent nonPortable} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list second $f]] - testchannelevent $f add readable [namespace code [list first $f]] +} -constraints testchannelevent -body { proc first {f} { variable u variable z if {$u eq "toplevel"} { lappend z "first called" + set mode [testservicemode 1] + set timer [after 50 lappend z timeout] set u first - update + vwait z + after cancel $timer + testservicemode $mode lappend z "first after update" } else { lappend z "first called not toplevel" @@ -6529,7 +6552,14 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { } set z "" set u toplevel - update + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list second $f]] + testchannelevent $f add readable [namespace code [list first $f]] + testservicemode 1 + vwait z + after cancel $timer set z } -cleanup { chan close $f diff --git a/tests/event.test b/tests/event.test index 6e6d116..b42909c 100644 --- a/tests/event.test +++ b/tests/event.test @@ -27,12 +27,13 @@ testConstraint exec [llength [info commands exec]] test event-1.1 {Tcl_CreateFileHandler, reading} -setup { testfilehandler close set result "" -} -constraints {testfilehandler nonPortable} -body { +} -constraints testfilehandler -body { testfilehandler create 0 readable off testfilehandler clear 0 testfilehandler oneevent lappend result [testfilehandler counts 0] testfilehandler fillpartial 0 + update idletasks testfilehandler oneevent lappend result [testfilehandler counts 0] testfilehandler oneevent @@ -595,16 +596,16 @@ test event-11.7 {Bug 16828b3744} { test event-11.8 {Bug 16828b3744} -setup { oo::class create A { variable continue - + method start {} { after idle [self] destroy - + set continue 0 vwait [namespace current]::continue } destructor { set continue 1 - } + } } } -body { [A new] start diff --git a/tests/io.test b/tests/io.test index e2b1a89..8c44db9 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6033,10 +6033,10 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { fileevent $f readable {} }] } + set timer [after 10 lappend x timeout] testfevent cmd $script - after 1 ;# We must delay because Windows takes a little time to notice - update - testfevent cmd {close $f} + vwait x + testfevent cmd {chan close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} test io-46.2 {Tcl event loop vs multiple interpreters} testfevent { @@ -6722,52 +6722,57 @@ test io-49.5 {testing crlf reading, leftover cr disgorgment} { set l } [list 7 a\rb\rc 7 {} 7 1] -test io-50.1 {testing handler deletion} -constraints {testchannelevent nonPortable} -setup { +test io-50.1 {testing handler deletion} -constraints testchannelevent -setup { file delete $path(test1) } -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f]] + update proc delhandler {f} { variable z set z called testchannelevent $f delete 0 } set z not_called - update + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f]] + testservicemode 1 + vwait z + after cancel $timer set z } -cleanup { close $f } -result called -test io-50.2 {testing handler deletion with multiple handlers} -constraints {testchannelevent nonPortable} -setup { +test io-50.2 {testing handler deletion with multiple handlers} -constraints testchannelevent -setup { file delete $path(test1) } -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] proc delhandler {f i} { variable z - lappend z "called delhandler $f $i" + lappend z "called delhandler $i" testchannelevent $f delete 0 } set z "" - update - string compare [string tolower $z] \ - [list [list called delhandler $f 0] [list called delhandler $f 1]] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z } -cleanup { close $f -} -result 0 -test io-50.3 {testing handler deletion with multiple handlers} -constraints {testchannelevent nonPortable} -setup { +} -result {{called delhandler 0} {called delhandler 1}} +test io-50.3 {testing handler deletion with multiple handlers} -constraints testchannelevent -setup { file delete $path(test1) } -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] set z "" proc notcalled {f i} { variable z @@ -6776,25 +6781,30 @@ test io-50.3 {testing handler deletion with multiple handlers} -constraints {tes proc delhandler {f i} { variable z testchannelevent $f delete 1 - lappend z "delhandler $f $i called" + lappend z "delhandler $i called" testchannelevent $f delete 0 - lappend z "delhandler $f $i deleted myself" + lappend z "delhandler $i deleted myself" } set z "" - update - string compare [string tolower $z] \ - [list [list delhandler $f 0 called] \ - [list delhandler $f 0 deleted myself]] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z } -cleanup { close $f -} -result 0 -test io-50.4 {testing handler deletion vs reentrant calls} -constraints {testchannelevent nonPortable} -setup { +} -result {{delhandler 0 called} {delhandler 0 deleted myself}} +test io-50.4 {testing handler deletion vs reentrant calls} -constraints testchannelevent -setup { file delete $path(test1) + update } -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delrecursive $f]] + update proc delrecursive {f} { variable z variable u @@ -6809,19 +6819,22 @@ test io-50.4 {testing handler deletion vs reentrant calls} -constraints {testcha } variable u toplevel variable z "" - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delrecursive $f]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer set z } -cleanup { close $f } -result {{delrecursive calling recursive} {delrecursive deleting recursive}} -test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testchannelevent nonPortable} -setup { +test io-50.5 {testing handler deletion vs reentrant calls} -constraints testchannelevent -setup { file delete $path(test1) } -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f]] - testchannelevent $f add readable [namespace code [list del $f]] proc notcalled {f} { variable z lappend z "notcalled was called!! $f" @@ -6831,40 +6844,48 @@ test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testcha variable z if {"$u" == "recursive"} { testchannelevent $f delete 1 - testchannelevent $f delete 0 lappend z "del deleted notcalled" + testchannelevent $f delete 0 lappend z "del deleted myself" } else { set u recursive lappend z "del calling recursive" - update - lappend z "del after update" + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + lappend z "del after recursive" } } set z "" set u toplevel - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f]] + testchannelevent $f add readable [namespace code [list del $f]] + testservicemode 1 + set timer [after 50 set z timeout] + vwait z + after cancel $timer set z } -cleanup { close $f } -result [list {del calling recursive} {del deleted notcalled} \ - {del deleted myself} {del after update}] -test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testchannelevent nonPortable} -setup { + {del deleted myself} {del after recursive}] +test io-50.6 {testing handler deletion vs reentrant calls} -constraints testchannelevent -setup { file delete $path(test1) } -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list second $f]] - testchannelevent $f add readable [namespace code [list first $f]] proc first {f} { variable u variable z if {"$u" == "toplevel"} { lappend z "first called" set u first - update - lappend z "first after update" + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + lappend z "first after toplevel" } else { lappend z "first called not toplevel" } @@ -6886,13 +6907,18 @@ test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testcha } set z "" set u toplevel + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list second $f]] + testchannelevent $f add readable [namespace code [list first $f]] + testservicemode 1 update set z } -cleanup { close $f } -result [list {first called} {first called not toplevel} \ {second called, first time} {second called, second time} \ - {first after update}] + {first after toplevel}] test io-51.1 {Test old socket deletion on Macintosh} {socket} { set x 0 |