From 4b765a3aff40f73f918d159af41222d1ce972b24 Mon Sep 17 00:00:00 2001
From: culler <culler>
Date: Sat, 8 Aug 2020 21:27:06 +0000
Subject: Add and use testservicemode command; replace update by vwait

---
 generic/tclTest.c | 52 ++++++++++++++++++++++++++++-
 tests/chanio.test | 42 +++++++++++++++--------
 tests/event.test  |  1 +
 tests/io.test     | 99 ++++++++++++++++++++++++++++++++++---------------------
 4 files changed, 141 insertions(+), 53 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 4f348f8..c48fe63 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -6394,14 +6394,16 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup {
     chan close [open $path(test1) w]
     set z ""
 } -constraints testchannelevent -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]]
     proc delhandler {f i} {
 	variable z
 	lappend z "called delhandler $f $i"
 	testchannelevent $f delete 0
     }
+    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
     update
     string equal $z \
 	[list [list called delhandler $f 0] [list called delhandler $f 1]]
@@ -6411,11 +6413,8 @@ 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 ""
+    update
 } -constraints testchannelevent -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]]
     proc notcalled {f i} {
 	variable z
 	lappend z "notcalled was called!! $f $i"
@@ -6427,6 +6426,12 @@ test chan-io-50.3 {testing handler deletion with multiple handlers} -setup {
 	testchannelevent $f delete 0
 	lappend z "delhandler $f $i deleted myself"
     }
+    set z ""
+    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
     update
     string equal $z \
 	[list [list delhandler $f 0 called] \
@@ -6438,6 +6443,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
+    update
 } -constraints testchannelevent -body {
     set f [open $path(test1) r]
     testchannelevent $f add readable [namespace code {
@@ -6456,15 +6462,14 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup {
     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
+    update
 } -constraints testchannelevent -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]]
     proc notcalled {f} {
 	variable z
 	lappend z "notcalled was called!! $f"
@@ -6480,22 +6485,31 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup {
 	} else {
 	    set u recursive
 	    lappend z "del calling recursive"
+	    set mode [test servicemode 1]
 	    update
+	    test servicemode $mode
 	    lappend z "del after update"
 	}
     }
     set z ""
     set u toplevel
+    testservicemode 0
+    set f [open $path(test1) r]
+    testchannelevent $f add readable [namespace code [list notcalled $f]]
+    testservicemode 1
+    testchannelevent $f add readable [namespace code [list del $f]]
     update
     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
+    update
 } -constraints testchannelevent -body {
     proc first {f} {
 	variable u
@@ -6503,7 +6517,9 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup {
 	if {$u eq "toplevel"} {
 	    lappend z "first called"
 	    set u first
+	    set mode [testservicemode 1]
 	    update
+	    testservicemode $mode
 	    lappend z "first after update"
 	} else {
 	    lappend z "first called not toplevel"
@@ -6526,13 +6542,11 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup {
     }
     set z ""
     set u toplevel
-    # This test assume that select will not detect the new open file
-    # until the update command runs.  This is not guaranteed, but it
-    # seems to help if we make sure that the calls to testchannelevent
-    # immediately follow the call to open.
+    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 {
diff --git a/tests/event.test b/tests/event.test
index 336c4e4..b42909c 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -33,6 +33,7 @@ test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
     testfilehandler oneevent
     lappend result [testfilehandler counts 0]
     testfilehandler fillpartial 0
+    update idletasks
     testfilehandler oneevent
     lappend result [testfilehandler counts 0]
     testfilehandler oneevent
diff --git a/tests/io.test b/tests/io.test
index c9019af..cfa08ed 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -6725,18 +6725,22 @@ test io-49.5 {testing crlf reading, leftover cr disgorgment} {
 test io-50.1 {testing handler deletion} -constraints testchannelevent -setup {
     file delete $path(test1)
 } -body {
+    set f [open $path(test1) w]
+    close $f
+    update
     proc delhandler {f} {
 	variable z
 	set z called
 	testchannelevent $f delete 0
     }
-    set f [open $path(test1) w]
-    close $f
     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]]
-    update
+    testservicemode 1
+    vwait z
+    after cancel $timer
     set z
 } -cleanup {
     close $f
@@ -6746,29 +6750,27 @@ test io-50.2 {testing handler deletion with multiple handlers} -constraints test
 } -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 ""
+    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
     update
-    string compare [string tolower $z] \
-	[list [list called delhandler $f 0] [list called delhandler $f 1]]
+    set z
 } -cleanup {
     close $f
-} -result 0
+} -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
@@ -6777,25 +6779,30 @@ test io-50.3 {testing handler deletion with multiple handlers} -constraints test
     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
+} -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
@@ -6810,7 +6817,13 @@ test io-50.4 {testing handler deletion vs reentrant calls} -constraints testchan
     }
     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
@@ -6820,9 +6833,6 @@ test io-50.5 {testing handler deletion vs reentrant calls} -constraints testchan
 } -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"
@@ -6832,40 +6842,48 @@ test io-50.5 {testing handler deletion vs reentrant calls} -constraints testchan
 	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}]
+	{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"
 	}
@@ -6887,13 +6905,18 @@ test io-50.6 {testing handler deletion vs reentrant calls} -constraints testchan
     }
     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
-- 
cgit v0.12