Merge core-9-0-branchcore-bug-40b1814b93

2 files changed, 52 insertions, 3 deletions

diff --git a/generic/tclTest.c b/generic/tclTest.c
index 367be00..c67ec25 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -336,6 +336,7 @@ static Tcl_ObjCmdProc	TestcpuidCmd;
 static Tcl_ObjCmdProc	TestApplyLambdaCmd;
 #ifdef _WIN32
 static Tcl_ObjCmdProc	TestHandleCountCmd;
+static Tcl_ObjCmdProc	TestAppVerifierPresentCmd;
 #endif
 
 static const Tcl_Filesystem testReportingFilesystem = {
@@ -731,6 +732,8 @@ Tcltest_Init(
 #if defined(_WIN32)
     Tcl_CreateObjCommand(interp, "testhandlecount", TestHandleCountCmd,
 	    NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testappverifierpresent",
+	    TestAppVerifierPresentCmd, NULL, NULL);
 #endif
 
     if (TclObjTest_Init(interp) != TCL_OK) {
@@ -8816,7 +8819,6 @@ vamoose:
  *
  *----------------------------------------------------------------------
  */
-
 static int
 TestHandleCountCmd(
     TCL_UNUSED(void *),
@@ -8837,6 +8839,49 @@ TestHandleCountCmd(
 	    "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 */
 
 /*
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