Merge commit '1005c7e630baa54e58ac331f48bf876011deb6b3' as 'tk8.6'

1 files changed, 583 insertions, 0 deletions

diff --git a/tk8.6/win/tkWinTest.c b/tk8.6/win/tkWinTest.c
new file mode 100644
index 0000000..6e79df3
--- /dev/null
+++ b/tk8.6/win/tkWinTest.c
@@ -0,0 +1,583 @@
+/*
+ * tkWinTest.c --
+ *
+ *	Contains commands for platform specific tests for the Windows
+ *	platform.
+ *
+ * Copyright (c) 1997 Sun Microsystems, Inc.
+ * Copyright (c) 2000 by Scriptics Corporation.
+ * Copyright (c) 2001 by ActiveState Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#undef USE_TCL_STUBS
+#define USE_TCL_STUBS
+#undef USE_TK_STUBS
+#define USE_TK_STUBS
+#include "tkWinInt.h"
+
+HWND tkWinCurrentDialog;
+
+/*
+ * Forward declarations of functions defined later in this file:
+ */
+
+static int		TestclipboardObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+static int		TestwineventObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+static int		TestfindwindowObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+static int		TestgetwindowinfoObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+static int		TestwinlocaleObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+static Tk_GetSelProc		SetSelectionResult;
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkplatformtestInit --
+ *
+ *	Defines commands that test platform specific functionality for Windows
+ *	platforms.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	Defines new commands.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TkplatformtestInit(
+    Tcl_Interp *interp)		/* Interpreter to add commands to. */
+{
+    /*
+     * Add commands for platform specific tests on MacOS here.
+     */
+
+    Tcl_CreateObjCommand(interp, "testclipboard", TestclipboardObjCmd,
+	    (ClientData) Tk_MainWindow(interp), NULL);
+    Tcl_CreateObjCommand(interp, "testwinevent", TestwineventObjCmd,
+	    (ClientData) Tk_MainWindow(interp), NULL);
+    Tcl_CreateObjCommand(interp, "testfindwindow", TestfindwindowObjCmd,
+	    (ClientData) Tk_MainWindow(interp), NULL);
+    Tcl_CreateObjCommand(interp, "testgetwindowinfo", TestgetwindowinfoObjCmd,
+	    (ClientData) Tk_MainWindow(interp), NULL);
+    Tcl_CreateObjCommand(interp, "testwinlocale", TestwinlocaleObjCmd,
+	    (ClientData) Tk_MainWindow(interp), NULL);
+    return TCL_OK;
+}
+
+struct TestFindControlState {
+    int  id;
+    HWND control;
+};
+
+/* Callback for window enumeration - used for TestFindControl */
+BOOL CALLBACK TestFindControlCallback(
+    HWND hwnd,
+    LPARAM lParam
+)
+{
+    struct TestFindControlState *fcsPtr = (struct TestFindControlState *)lParam;
+    fcsPtr->control = GetDlgItem(hwnd, fcsPtr->id);
+    /* If we have found the control, return FALSE to stop the enumeration */
+    return fcsPtr->control == NULL ? TRUE : FALSE;
+}
+
+/*
+ * Finds the descendent control window with the specified ID and returns
+ * its HWND.
+ */
+HWND TestFindControl(HWND root, int id)
+{
+    struct TestFindControlState fcs;
+
+    fcs.control = GetDlgItem(root, id);
+    if (fcs.control == NULL) {
+        /* Control is not a direct child. Look in descendents */
+        fcs.id = id;
+        fcs.control = NULL;
+        EnumChildWindows(root, TestFindControlCallback, (LPARAM) &fcs);
+    }
+    return fcs.control;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AppendSystemError --
+ *
+ *	This routine formats a Windows system error message and places it into
+ *	the interpreter result. Originally from tclWinReg.c.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AppendSystemError(
+    Tcl_Interp *interp,		/* Current interpreter. */
+    DWORD error)		/* Result code from error. */
+{
+    int length;
+    WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr;
+    const char *msg;
+    char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
+    Tcl_DString ds;
+    Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+
+    if (Tcl_IsShared(resultPtr)) {
+	resultPtr = Tcl_DuplicateObj(resultPtr);
+    }
+    length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
+	    | FORMAT_MESSAGE_IGNORE_INSERTS
+	    | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
+	    MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr,
+	    0, NULL);
+    if (length == 0) {
+	char *msgPtr;
+
+	length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM
+		| FORMAT_MESSAGE_IGNORE_INSERTS
+		| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
+		MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr,
+		0, NULL);
+	if (length > 0) {
+	    wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR));
+	    MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr,
+		    length + 1);
+	    LocalFree(msgPtr);
+	}
+    }
+    if (length == 0) {
+	if (error == ERROR_CALL_NOT_IMPLEMENTED) {
+	    strcpy(msgBuf, "function not supported under Win32s");
+	} else {
+	    sprintf(msgBuf, "unknown error: %ld", error);
+	}
+	msg = msgBuf;
+    } else {
+	Tcl_Encoding encoding;
+	char *msgPtr;
+
+	encoding = Tcl_GetEncoding(NULL, "unicode");
+	Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
+	Tcl_FreeEncoding(encoding);
+	LocalFree(wMsgPtr);
+
+	msgPtr = Tcl_DStringValue(&ds);
+	length = Tcl_DStringLength(&ds);
+
+	/*
+	 * Trim the trailing CR/LF from the system message.
+	 */
+
+	if (msgPtr[length-1] == '\n') {
+	    --length;
+	}
+	if (msgPtr[length-1] == '\r') {
+	    --length;
+	}
+	msgPtr[length] = 0;
+	msg = msgPtr;
+    }
+
+    sprintf(id, "%ld", error);
+    Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL);
+    Tcl_AppendToObj(resultPtr, msg, length);
+    Tcl_SetObjResult(interp, resultPtr);
+
+    if (length != 0) {
+	Tcl_DStringFree(&ds);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestclipboardObjCmd --
+ *
+ *	This function implements the testclipboard command. It provides a way
+ *	to determine the actual contents of the Windows clipboard.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetSelectionResult(
+    ClientData dummy,
+    Tcl_Interp *interp,
+    const char *selection)
+{
+    Tcl_AppendResult(interp, selection, NULL);
+    return TCL_OK;
+}
+
+static int
+TestclipboardObjCmd(
+    ClientData clientData,	/* Main window for application. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument values. */
+{
+    Tk_Window tkwin = (Tk_Window) clientData;
+
+    if (objc != 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, NULL);
+	return TCL_ERROR;
+    }
+    return TkSelGetSelection(interp, tkwin, Tk_InternAtom(tkwin, "CLIPBOARD"),
+	    XA_STRING, SetSelectionResult, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestwineventObjCmd --
+ *
+ *	This function implements the testwinevent command. It provides a way
+ *	to send messages to windows dialogs.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestwineventObjCmd(
+    ClientData clientData,	/* Main window for application. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])		/* Argument strings. */
+{
+    HWND hwnd = 0;
+    HWND child = 0;
+    HWND control;
+    int id;
+    char *rest;
+    UINT message;
+    WPARAM wParam;
+    LPARAM lParam;
+    LRESULT result;
+    static const TkStateMap messageMap[] = {
+	{WM_LBUTTONDOWN,	"WM_LBUTTONDOWN"},
+	{WM_LBUTTONUP,		"WM_LBUTTONUP"},
+	{WM_CHAR,		"WM_CHAR"},
+	{WM_GETTEXT,		"WM_GETTEXT"},
+	{WM_SETTEXT,		"WM_SETTEXT"},
+	{WM_COMMAND,            "WM_COMMAND"},
+	{-1,			NULL}
+    };
+
+    if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]), "debug") == 0)) {
+	int b;
+
+	if (Tcl_GetBoolean(interp, Tcl_GetString(objv[2]), &b) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	TkWinDialogDebug(b);
+	return TCL_OK;
+    }
+
+    if (objc < 4) {
+	return TCL_ERROR;
+    }
+
+    hwnd = INT2PTR(strtol(Tcl_GetString(objv[1]), &rest, 0));
+    if (rest == Tcl_GetString(objv[1])) {
+	hwnd = FindWindowA(NULL, Tcl_GetString(objv[1]));
+	if (hwnd == NULL) {
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj("no such window", -1));
+	    return TCL_ERROR;
+	}
+    }
+    UpdateWindow(hwnd);
+
+    id = strtol(Tcl_GetString(objv[2]), &rest, 0);
+    if (rest == Tcl_GetString(objv[2])) {
+	char buf[256];
+
+	child = GetWindow(hwnd, GW_CHILD);
+	while (child != NULL) {
+	    SendMessageA(child, WM_GETTEXT, (WPARAM) sizeof(buf), (LPARAM) buf);
+	    if (strcasecmp(buf, Tcl_GetString(objv[2])) == 0) {
+		id = GetDlgCtrlID(child);
+		break;
+	    }
+	    child = GetWindow(child, GW_HWNDNEXT);
+	}
+	if (child == NULL) {
+	    Tcl_AppendResult(interp, "could not find a control matching \"",
+		Tcl_GetString(objv[2]), "\"", NULL);
+	    return TCL_ERROR;
+	}
+    }
+
+    message = TkFindStateNum(NULL, NULL, messageMap, Tcl_GetString(objv[3]));
+    wParam = 0;
+    lParam = 0;
+
+    if (objc > 4) {
+	wParam = strtol(Tcl_GetString(objv[4]), NULL, 0);
+    }
+    if (objc > 5) {
+	lParam = strtol(Tcl_GetString(objv[5]), NULL, 0);
+    }
+
+    switch (message) {
+    case WM_GETTEXT: {
+	Tcl_DString ds;
+	char buf[256];
+
+#if 0
+	GetDlgItemTextA(hwnd, id, buf, 256);
+#else
+        control = TestFindControl(hwnd, id);
+        if (control == NULL) {
+            Tcl_SetObjResult(interp,
+                             Tcl_ObjPrintf("Could not find control with id %d", id));
+            return TCL_ERROR;
+        }
+        buf[0] = 0;
+        SendMessageA(control, WM_GETTEXT, (WPARAM)sizeof(buf),
+                     (LPARAM) buf);
+#endif
+	Tcl_ExternalToUtfDString(NULL, buf, -1, &ds);
+	Tcl_AppendResult(interp, Tcl_DStringValue(&ds), NULL);
+	Tcl_DStringFree(&ds);
+	break;
+    }
+    case WM_SETTEXT: {
+	Tcl_DString ds;
+
+        control = TestFindControl(hwnd, id);
+        if (control == NULL) {
+            Tcl_SetObjResult(interp,
+                             Tcl_ObjPrintf("Could not find control with id %d", id));
+            return TCL_ERROR;
+        }
+	Tcl_UtfToExternalDString(NULL, Tcl_GetString(objv[4]), -1, &ds);
+        result = SendMessageA(control, WM_SETTEXT, 0,
+                                  (LPARAM) Tcl_DStringValue(&ds));
+	Tcl_DStringFree(&ds);
+	if (result == 0) {
+            Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to send text to dialog: ", -1));
+            AppendSystemError(interp, GetLastError());
+            return TCL_ERROR;
+	}
+	break;
+    }
+    case WM_COMMAND: {
+	char buf[TCL_INTEGER_SPACE];
+	if (objc < 5) {
+	    wParam = MAKEWPARAM(id, 0);
+	    lParam = (LPARAM)child;
+	}
+	sprintf(buf, "%d", (int) SendMessageA(hwnd, message, wParam, lParam));
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
+	break;
+    }
+    default: {
+	char buf[TCL_INTEGER_SPACE];
+
+	sprintf(buf, "%d",
+		(int) SendDlgItemMessageA(hwnd, id, message, wParam, lParam));
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
+	break;
+    }
+    }
+    return TCL_OK;
+}
+
+/*
+ *  testfindwindow title ?class?
+ *	Find a Windows window using the FindWindow API call. This takes the window
+ *	title and optionally the window class and if found returns the HWND and
+ *	raises an error if the window is not found.
+ *	eg: testfindwindow Console TkTopLevel
+ *	    Can find the console window if it is visible.
+ *	eg: testfindwindow "TkTest #10201" "#32770"
+ *	    Can find a messagebox window with this title.
+ */
+
+static int
+TestfindwindowObjCmd(
+    ClientData clientData,	/* Main window for application. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument values. */
+{
+    const TCHAR  *title = NULL, *class = NULL;
+    Tcl_DString titleString, classString;
+    HWND hwnd = NULL;
+    int r = TCL_OK;
+    DWORD myPid;
+
+    Tcl_DStringInit(&classString);
+    Tcl_DStringInit(&titleString);
+
+    if (objc < 2 || objc > 3) {
+        Tcl_WrongNumArgs(interp, 1, objv, "title ?class?");
+        return TCL_ERROR;
+    }
+
+    title = Tcl_WinUtfToTChar(Tcl_GetString(objv[1]), -1, &titleString);
+    if (objc == 3) {
+        class = Tcl_WinUtfToTChar(Tcl_GetString(objv[2]), -1, &classString);
+    }
+    if (title[0] == 0)
+        title = NULL;
+#if 0
+    hwnd  = FindWindow(class, title);
+#else
+    /* We want find a window the belongs to us and not some other process */
+    hwnd = NULL;
+    myPid = GetCurrentProcessId();
+    while (1) {
+        DWORD pid, tid;
+        hwnd = FindWindowEx(NULL, hwnd, class, title);
+        if (hwnd == NULL)
+            break;
+        tid = GetWindowThreadProcessId(hwnd, &pid);
+        if (tid == 0) {
+            /* Window has gone */
+            hwnd = NULL;
+            break;
+        }
+        if (pid == myPid)
+            break;              /* Found it */
+    }
+
+#endif
+
+    if (hwnd == NULL) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to find window: ", -1));
+	AppendSystemError(interp, GetLastError());
+	r = TCL_ERROR;
+    } else {
+        Tcl_SetObjResult(interp, Tcl_NewLongObj(PTR2INT(hwnd)));
+    }
+
+    Tcl_DStringFree(&titleString);
+    Tcl_DStringFree(&classString);
+    return r;
+
+}
+
+static BOOL CALLBACK
+EnumChildrenProc(
+    HWND hwnd,
+    LPARAM lParam)
+{
+    Tcl_Obj *listObj = (Tcl_Obj *) lParam;
+
+    Tcl_ListObjAppendElement(NULL, listObj, Tcl_NewLongObj(PTR2INT(hwnd)));
+    return TRUE;
+}
+
+static int
+TestgetwindowinfoObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    long hwnd;
+    Tcl_Obj *dictObj = NULL, *classObj = NULL, *textObj = NULL;
+    Tcl_Obj *childrenObj = NULL;
+    TCHAR buf[512];
+    int cch, cchBuf = 256;
+    Tcl_DString ds;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "hwnd");
+	return TCL_ERROR;
+    }
+
+    if (Tcl_GetLongFromObj(interp, objv[1], &hwnd) != TCL_OK)
+	return TCL_ERROR;
+
+    cch = GetClassName(INT2PTR(hwnd), buf, cchBuf);
+    if (cch == 0) {
+    	Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to get class name: ", -1));
+    	AppendSystemError(interp, GetLastError());
+    	return TCL_ERROR;
+    } else {
+	Tcl_DString ds;
+	Tcl_WinTCharToUtf(buf, -1, &ds);
+	classObj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
+	Tcl_DStringFree(&ds);
+    }
+
+    dictObj = Tcl_NewDictObj();
+    Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("class", 5), classObj);
+    Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("id", 2),
+	Tcl_NewLongObj(GetWindowLongA(INT2PTR(hwnd), GWL_ID)));
+
+    cch = GetWindowText(INT2PTR(hwnd), (LPTSTR)buf, cchBuf);
+    Tcl_WinTCharToUtf(buf, cch * sizeof (WCHAR), &ds);
+    textObj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
+    Tcl_DStringFree(&ds);
+
+    Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("text", 4), textObj);
+    Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("parent", 6),
+	Tcl_NewLongObj(PTR2INT(GetParent((INT2PTR(hwnd))))));
+
+    childrenObj = Tcl_NewListObj(0, NULL);
+    EnumChildWindows(INT2PTR(hwnd), EnumChildrenProc, (LPARAM)childrenObj);
+    Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("children", -1), childrenObj);
+
+    Tcl_SetObjResult(interp, dictObj);
+    return TCL_OK;
+}
+
+static int
+TestwinlocaleObjCmd(
+    ClientData clientData,	/* Main window for application. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument values. */
+{
+    if (objc != 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, NULL);
+	return TCL_ERROR;
+    }
+    Tcl_SetObjResult(interp, Tcl_NewIntObj((int)GetThreadLocale()));
+    return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */