merge trunkcore-arith-series-bytecode

3 files changed, 137 insertions, 2 deletions

diff --git a/generic/tclTest.c b/generic/tclTest.c
index 1747006..2e578dd 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -334,6 +334,10 @@ static Tcl_ObjCmdProc	TestInterpResolverCmd;
 static Tcl_ObjCmdProc	TestcpuidCmd;
 #endif
 static Tcl_ObjCmdProc	TestApplyLambdaCmd;
+#ifdef _WIN32
+static Tcl_ObjCmdProc	TestHandleCountCmd;
+static Tcl_ObjCmdProc	TestAppVerifierPresentCmd;
+#endif
 
 static const Tcl_Filesystem testReportingFilesystem = {
     "reporting",
@@ -725,6 +729,12 @@ Tcltest_Init(
 	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "testlutil", TestLutilCmd,
 	    NULL, NULL);
+#if defined(_WIN32)
+    Tcl_CreateObjCommand(interp, "testhandlecount", TestHandleCountCmd,
+	    NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testappverifierpresent",
+	    TestAppVerifierPresentCmd, NULL, NULL);
+#endif
 
     if (TclObjTest_Init(interp) != TCL_OK) {
 	return TCL_ERROR;
@@ -8824,6 +8834,88 @@ vamoose:
     return ret;
 }
 
+#ifdef _WIN32
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestHandleCountCmd --
+ *
+ *	This procedure implements the "testhandlecount" command. It returns
+ *	the number of open handles in the process.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+TestHandleCountCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Arguments. */
+{
+    DWORD count;
+    if (objc != 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, "");
+	return TCL_ERROR;
+    }
+    if (GetProcessHandleCount(GetCurrentProcess(), &count)) {
+	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(count));
+	return TCL_OK;
+    }
+    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+	    "GetProcessHandleCount failed", -1));
+    return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestAppVerifierPresentCmd --
+ *
+ *	This procedure implements the "testappverifierpresent" command.
+ *	Result is 1 if the process is running under the Application Verifier,
+ *	0 otherwise.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+TestAppVerifierPresentCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Arguments. */
+{
+    if (objc != 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, "");
+	return TCL_ERROR;
+    }
+    const char *dlls[] = {
+	"verifier.dll", "vfbasics.dll", "vfcompat.dll", "vfnet.dll", NULL
+    };
+    const char **dll;
+    for (dll = dlls; dll; ++dll) {
+	if (GetModuleHandleA(*dll) != NULL) {
+	    break;
+	}
+    }
+    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(*dll != NULL));
+    return TCL_OK;
+}
+
+
+#endif /* _WIN32 */
+
 /*
  * Local Variables:
  * mode: c
diff --git a/tests/exec.test b/tests/exec.test
index 06d6bea..fc5f1fa 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -32,6 +32,8 @@ if {[testConstraint win] && ![info exists ::env(CI)] &&
 	testConstraint haveWinget 1
 }
 
+testConstraint testhandlecount [expr {[llength [info commands testhandlecount]] != 0}]
+
 unset -nocomplain path
 
 # Utilities that are like Bourne shell stalwarts, but cross-platform.
@@ -154,6 +156,12 @@ test exec-1.4 {long command lines} {exec} {
     exec [interpreter] $path(echo) $arg
 } $arg
 set arg {}
+test exec-1.5 {pipelining - handle leaks} -constraints {exec stdio testhandlecount} -body {
+    set numHandles [testhandlecount]
+    set a [exec [interpreter] $path(echo) a b c d | [interpreter] $path(cat) | [interpreter] $path(wc)]
+    list [scan $a "%d %d %d" b c d] $b $c [expr {[testhandlecount] - $numHandles}]
+} -result {3 1 4 0}
+
 
 # I/O redirection: input from Tcl command.
 
@@ -190,6 +198,13 @@ test exec-2.6 {redirecting input from immediate source, with UTF} -setup {
     encoding system $sysenc
     rename quotenonascii {}
 } -result {\xE9\xE0\xFC\xF1}
+test exec-2.7 {handle count redirecting input from immediate source} -constraints {
+    exec stdio testhandlecount
+} -body {
+    set numHandles [testhandlecount]
+    list [exec [interpreter] $path(cat) | [interpreter] $path(cat) << "Sample text"] \
+        [expr {[testhandlecount] - $numHandles}]
+} -result [list {Sample text} 0]
 
 # I/O redirection: output to file.
 
@@ -232,6 +247,14 @@ test exec-3.7 {redirecting output to file} {exec} {
     close $f
     exec [interpreter] $path(cat) $path(gorp.file)
 } "Line 1\nMore text\nEven more\nLine 3"
+test exec-3.8 {handle count redirecting output to file} -constraints {
+    exec stdio testhandlecount
+} -body {
+    set numHandles [testhandlecount]
+    exec > $path(gorp.file) [interpreter] $path(echo) "Different simple words" | [interpreter] $path(cat) | [interpreter] $path(cat)
+    list [exec [interpreter] $path(cat) $path(gorp.file)] \
+        [expr {[testhandlecount] - $numHandles}]
+} -result [list "Different simple words" 0]
 
 # I/O redirection: output and stderr to file.
 
@@ -303,6 +326,13 @@ test exec-5.7 {redirecting input from file} -constraints {exec} -body {
 } -cleanup {
     close $f
 } -result {Just a few thoughts}
+test exec-5.8 {handle count redirecting input from file} -constraints {
+    exec stdio testhandlecount
+} -body {
+    set numHandles [testhandlecount]
+    list [exec [interpreter] $path(cat) | [interpreter] $path(cat) < $path(gorp.file)] \
+        [expr {[testhandlecount] - $numHandles}]
+} -result [list {Just a few thoughts} 0]
 
 # I/O redirection: standard error through a pipeline.
 
@@ -484,6 +514,15 @@ test exec-11.5 {commands in background} {exec} {
     close $f
     exec [interpreter] $path(gorp.file)
 } foo
+test exec-11.6 {commands in background} -constraints {
+    exec stdio testhandlecount
+} -body {
+    set numHandles [testhandlecount]
+    set n [llength [exec [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 &]]
+    after 1100
+    tcl::process::purge
+    list $n [expr {([testhandlecount] - $numHandles) <= 0}]; # Could be < 0 if prior processes were reaped
+} -result {3 1}
 
 # Make sure that background commands are properly reaped when they
 # eventually die.
diff --git a/tests/main.test b/tests/main.test
index c245b0e..a3d7d28 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -16,6 +16,10 @@ namespace eval ::tcl::test::main {
 	[llength [package provide tcl::test]]
 	&& [package vsatisfies [package provide tcl::test] 8.5-]}]
 
+    testConstraint noappverifier [expr {
+        [llength [info commands testappverifierpresent]] == 0
+        || ![testappverifierpresent]}]
+
     # Procedure to simulate interactive typing of commands, line by line
     proc type {chan script} {
 	foreach line [split $script \n] {
@@ -548,7 +552,7 @@ namespace eval ::tcl::test::main {
     test Tcl_Main-4.5 {
 	Tcl_Main: Bug 1481986
     } -constraints {
-	exec tcl::test
+	exec tcl::test noappverifier
     } -setup {
 	set rc [makeFile {
 		testsetmainloop
@@ -1154,7 +1158,7 @@ namespace eval ::tcl::test::main {
     test Tcl_Main-8.10 {
 	StdinProc: interactive output, closed stdout
     } -constraints {
-	exec tcl::test
+	exec tcl::test noappverifier
     } -body {
 	exec [interpreter] << {
 		testsetmainloop