Initial revision

1 files changed, 130 insertions, 0 deletions

diff --git a/win/tclWinTest.c b/win/tclWinTest.c
new file mode 100644
index 0000000..cb61403
--- /dev/null
+++ b/win/tclWinTest.c
@@ -0,0 +1,130 @@
+/* 
+ * tclWinTest.c --
+ *
+ *	Contains commands for platform specific tests on Windows.
+ *
+ * Copyright (c) 1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWinTest.c 1.2 97/03/20 15:04:12
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * Forward declarations of procedures defined later in this file:
+ */
+int			TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
+static int		TesteventloopCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int argc, char **argv));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclplatformtestInit --
+ *
+ *	Defines commands that test platform specific functionality for
+ *	Unix platforms.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	Defines new commands.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclplatformtestInit(interp)
+    Tcl_Interp *interp;		/* Interpreter to add commands to. */
+{
+    /*
+     * Add commands for platform specific tests for Windows here.
+     */
+
+    Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
+            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TesteventloopCmd --
+ *
+ *	This procedure implements the "testeventloop" command. It is
+ *	used to test the Tcl notifier from an "external" event loop
+ *	(i.e. not Tcl_DoOneEvent()).
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TesteventloopCmd(clientData, interp, argc, argv)
+    ClientData clientData;		/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+    static int *framePtr = NULL; /* Pointer to integer on stack frame of
+				  * innermost invocation of the "wait"
+				  * subcommand. */
+
+   if (argc < 2) {
+	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
+                " option ... \"", (char *) NULL);
+        return TCL_ERROR;
+    }
+    if (strcmp(argv[1], "done") == 0) {
+	*framePtr = 1;
+    } else if (strcmp(argv[1], "wait") == 0) {
+	int *oldFramePtr;
+	int done;
+	MSG msg;
+	int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
+
+	/*
+	 * Save the old stack frame pointer and set up the current frame.
+	 */
+
+	oldFramePtr = framePtr;
+	framePtr = &done;
+
+	/*
+	 * Enter a standard Windows event loop until the flag changes.
+	 * Note that we do not explicitly call Tcl_ServiceEvent().
+	 */
+
+	done = 0;
+	while (!done) {
+	    if (!GetMessage(&msg, NULL, 0, 0)) {
+		/*
+		 * The application is exiting, so repost the quit message
+		 * and start unwinding.
+		 */
+
+		PostQuitMessage(msg.wParam);
+		break;
+	    }
+	    TranslateMessage(&msg);
+	    DispatchMessage(&msg);
+	}
+	(void) Tcl_SetServiceMode(oldMode);
+	framePtr = oldFramePtr;
+    } else {
+	Tcl_AppendResult(interp, "bad option \"", argv[1],
+		"\": must be done or wait", (char *) NULL);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}