summaryrefslogtreecommitdiffstats
path: root/win/tkWinTest.c
diff options
context:
space:
mode:
Diffstat (limited to 'win/tkWinTest.c')
-rw-r--r--win/tkWinTest.c315
1 files changed, 232 insertions, 83 deletions
diff --git a/win/tkWinTest.c b/win/tkWinTest.c
index bad3df3..d361ad7 100644
--- a/win/tkWinTest.c
+++ b/win/tkWinTest.c
@@ -1,40 +1,49 @@
-/*
+/*
* tkWinTest.c --
*
- * Contains commands for platform specific tests for
- * the Windows platform.
+ * 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.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tkWinInt.h"
HWND tkWinCurrentDialog;
-
+
/*
- * Forward declarations of procedures defined later in this file:
+ * Forward declarations of functions defined later in this file:
*/
-int TkplatformtestInit(Tcl_Interp *interp);
static int TestclipboardObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]);
-static int TestwineventCmd(ClientData clientData,
+static int TestwineventCmd(ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv);
-
+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[]);
+MODULE_SCOPE int TkplatformtestInit(Tcl_Interp *interp);
+
/*
*----------------------------------------------------------------------
*
* TkplatformtestInit --
*
- * Defines commands that test platform specific functionality for
- * Unix platforms.
+ * Defines commands that test platform specific functionality for Windows
+ * platforms.
*
* Results:
* A standard Tcl result.
@@ -52,12 +61,17 @@ TkplatformtestInit(
/*
* Add commands for platform specific tests on MacOS here.
*/
-
+
Tcl_CreateObjCommand(interp, "testclipboard", TestclipboardObjCmd,
- (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) Tk_MainWindow(interp), NULL);
Tcl_CreateCommand(interp, "testwinevent", TestwineventCmd,
- (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
-
+ (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;
}
@@ -66,8 +80,8 @@ TkplatformtestInit(
*
* AppendSystemError --
*
- * This routine formats a Windows system error message and places
- * it into the interpreter result. Originally from tclWinReg.c.
+ * This routine formats a Windows system error message and places it into
+ * the interpreter result. Originally from tclWinReg.c.
*
* Results:
* None.
@@ -84,7 +98,7 @@ AppendSystemError(
DWORD error) /* Result code from error. */
{
int length;
- WCHAR *wMsgPtr;
+ WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr;
char *msg;
char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
Tcl_DString ds;
@@ -92,7 +106,7 @@ AppendSystemError(
length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
- MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) &wMsgPtr,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr,
0, NULL);
if (length == 0) {
char *msgPtr;
@@ -128,6 +142,7 @@ AppendSystemError(
/*
* Trim the trailing CR/LF from the system message.
*/
+
if (msg[length-1] == '\n') {
msg[--length] = 0;
}
@@ -137,7 +152,7 @@ AppendSystemError(
}
sprintf(id, "%ld", error);
- Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL);
+ Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL);
Tcl_AppendToObj(resultPtr, msg, length);
if (length != 0) {
@@ -150,8 +165,8 @@ AppendSystemError(
*
* TestclipboardObjCmd --
*
- * This procedure implements the testclipboard command. It provides
- * a way to determine the actual contents of the Windows clipboard.
+ * This function implements the testclipboard command. It provides a way
+ * to determine the actual contents of the Windows clipboard.
*
* Results:
* A standard Tcl result.
@@ -163,40 +178,40 @@ AppendSystemError(
*/
static int
-TestclipboardObjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Main window for application. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument values. */
+TestclipboardObjCmd(
+ ClientData clientData, /* Main window for application. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument values. */
{
HGLOBAL handle;
char *data;
int code = TCL_OK;
if (objc != 1) {
- Tcl_WrongNumArgs(interp, 1, objv, (char *) NULL);
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
if (OpenClipboard(NULL)) {
/*
- * We could consider using CF_UNICODETEXT on NT, but then we
- * would have to convert it from External. Instead we'll just
- * take this and do "bytestring" at the Tcl level for Unicode
- * inclusive text
+ * We could consider using CF_UNICODETEXT on NT, but then we would
+ * have to convert it from External. Instead we'll just take this and
+ * do "bytestring" at the Tcl level for Unicode inclusive text
*/
+
handle = GetClipboardData(CF_TEXT);
if (handle != NULL) {
data = GlobalLock(handle);
- Tcl_AppendResult(interp, data, (char *) NULL);
+ Tcl_AppendResult(interp, data, NULL);
GlobalUnlock(handle);
} else {
- Tcl_AppendResult(interp, "null clipboard handle", (char *) NULL);
+ Tcl_AppendResult(interp, "null clipboard handle", NULL);
code = TCL_ERROR;
}
CloseClipboard();
return code;
} else {
- Tcl_AppendResult(interp, "couldn't open clipboard: ", (char *) NULL);
+ Tcl_AppendResult(interp, "couldn't open clipboard: ", NULL);
AppendSystemError(interp, GetLastError());
return TCL_ERROR;
}
@@ -208,8 +223,8 @@ TestclipboardObjCmd(clientData, interp, objc, objv)
*
* TestwineventCmd --
*
- * This procedure implements the testwinevent command. It provides
- * a way to send messages to windows dialogs.
+ * This function implements the testwinevent command. It provides a way
+ * to send messages to windows dialogs.
*
* Results:
* A standard Tcl result.
@@ -221,24 +236,26 @@ TestclipboardObjCmd(clientData, interp, objc, objv)
*/
static int
-TestwineventCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Main window for application. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestwineventCmd(
+ ClientData clientData, /* Main window for application. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ CONST char **argv) /* Argument strings. */
{
HWND hwnd = 0;
+ HWND child = 0;
int id;
char *rest;
UINT message;
WPARAM wParam;
LPARAM lParam;
- static TkStateMap messageMap[] = {
+ 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}
};
@@ -256,17 +273,7 @@ TestwineventCmd(clientData, interp, argc, argv)
return TCL_ERROR;
}
-#if 0
- TkpScanWindowId(interp, argv[1], &id);
- if (
-#ifdef _WIN64
- (sscanf(string, "0x%p", &number) != 1) &&
-#endif
- Tcl_GetInt(interp, string, (int *)&number) != TCL_OK) {
- return TCL_ERROR;
- }
-#endif
- hwnd = (HWND) strtol(argv[1], &rest, 0);
+ hwnd = (HWND) INT2PTR(strtol(argv[1], &rest, 0));
if (rest == argv[1]) {
hwnd = FindWindow(NULL, argv[1]);
if (hwnd == NULL) {
@@ -278,7 +285,6 @@ TestwineventCmd(clientData, interp, argc, argv)
id = strtol(argv[2], &rest, 0);
if (rest == argv[2]) {
- HWND child;
char buf[256];
child = GetWindow(hwnd, GW_CHILD);
@@ -291,13 +297,12 @@ TestwineventCmd(clientData, interp, argc, argv)
child = GetWindow(child, GW_HWNDNEXT);
}
if (child == NULL) {
+ Tcl_AppendResult(interp, "could not find a control matching \"",
+ argv[2], "\"", NULL);
return TCL_ERROR;
}
}
message = TkFindStateNum(NULL, NULL, messageMap, argv[3]);
- if (message < 0) {
- message = strtol(argv[3], NULL, 0);
- }
wParam = 0;
lParam = 0;
@@ -309,35 +314,179 @@ TestwineventCmd(clientData, interp, argc, argv)
}
switch (message) {
- case WM_GETTEXT: {
- Tcl_DString ds;
- char buf[256];
-
- GetDlgItemText(hwnd, id, buf, 256);
- Tcl_ExternalToUtfDString(NULL, buf, -1, &ds);
- Tcl_AppendResult(interp, Tcl_DStringValue(&ds), NULL);
- Tcl_DStringFree(&ds);
- break;
- }
- case WM_SETTEXT: {
- Tcl_DString ds;
+ case WM_GETTEXT: {
+ Tcl_DString ds;
+ char buf[256];
- Tcl_UtfToExternalDString(NULL, argv[4], -1, &ds);
- SetDlgItemText(hwnd, id, Tcl_DStringValue(&ds));
- Tcl_DStringFree(&ds);
- break;
- }
- default: {
- char buf[TCL_INTEGER_SPACE];
-
- sprintf(buf, "%d",
- (int) SendDlgItemMessage(hwnd, id, message, wParam, lParam));
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- break;
+ GetDlgItemText(hwnd, id, buf, 256);
+ Tcl_ExternalToUtfDString(NULL, buf, -1, &ds);
+ Tcl_AppendResult(interp, Tcl_DStringValue(&ds), NULL);
+ Tcl_DStringFree(&ds);
+ break;
+ }
+ case WM_SETTEXT: {
+ Tcl_DString ds;
+
+ Tcl_UtfToExternalDString(NULL, argv[4], -1, &ds);
+ SetDlgItemText(hwnd, id, Tcl_DStringValue(&ds));
+ Tcl_DStringFree(&ds);
+ break;
+ }
+ case WM_COMMAND: {
+ char buf[TCL_INTEGER_SPACE];
+ if (argc < 5) {
+ wParam = MAKEWPARAM(id, 0);
+ lParam = (LPARAM)child;
}
+ sprintf(buf, "%d", (int) SendMessage(hwnd, message, wParam, lParam));
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ break;
+ }
+ default: {
+ char buf[TCL_INTEGER_SPACE];
+
+ sprintf(buf, "%d",
+ (int) SendDlgItemMessage(hwnd, id, message, wParam, lParam));
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ 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 char *title = NULL, *class = NULL;
+ HWND hwnd = NULL;
+ int r = TCL_OK;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "title ?class?");
+ return TCL_ERROR;
+ }
+ title = Tcl_GetString(objv[1]);
+ if (objc == 3)
+ class = Tcl_GetString(objv[2]);
+ hwnd = FindWindowA(class, title);
+
+ 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)));
+ }
+ 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 *resObj = NULL, *classObj = NULL, *textObj = NULL;
+ Tcl_Obj *childrenObj = NULL;
+ char buf[512];
+ int cch, cchBuf = tkWinProcs->useWide ? 256 : 512;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "hwnd");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetLongFromObj(interp, objv[1], &hwnd) != TCL_OK)
+ return TCL_ERROR;
+
+ if (tkWinProcs->useWide) {
+ cch = GetClassNameW(INT2PTR(hwnd), (LPWSTR)buf, sizeof(buf)/sizeof(WCHAR));
+ classObj = Tcl_NewUnicodeObj((LPWSTR)buf, cch);
+ } else {
+ cch = GetClassNameA(INT2PTR(hwnd), (LPSTR)buf, sizeof(buf));
+ classObj = Tcl_NewStringObj((LPSTR)buf, cch);
+ }
+ if (cch == 0) {
+ Tcl_SetResult(interp, "failed to get class name: ", TCL_STATIC);
+ AppendSystemError(interp, GetLastError());
+ return TCL_ERROR;
+ }
+ resObj = Tcl_NewListObj(0, NULL);
+ Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("class", -1));
+ Tcl_ListObjAppendElement(interp, resObj, classObj);
+ Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("id", -1));
+ Tcl_ListObjAppendElement(interp, resObj,
+ Tcl_NewLongObj(GetWindowLong(INT2PTR(hwnd), GWL_ID)));
+
+ cch = tkWinProcs->getWindowText(INT2PTR(hwnd), (LPTSTR)buf, cchBuf);
+ if (tkWinProcs->useWide) {
+ textObj = Tcl_NewUnicodeObj((LPCWSTR)buf, cch);
+ } else {
+ textObj = Tcl_NewStringObj((LPCSTR)buf, cch);
+ }
+
+ Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("text", -1));
+ Tcl_ListObjAppendElement(interp, resObj, textObj);
+ Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("parent", -1));
+ Tcl_ListObjAppendElement(interp, resObj,
+ Tcl_NewLongObj(PTR2INT(GetParent(INT2PTR(hwnd)))));
+
+ childrenObj = Tcl_NewListObj(0, NULL);
+ EnumChildWindows(INT2PTR(hwnd), EnumChildrenProc, (LPARAM)childrenObj);
+ Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("children", -1));
+ Tcl_ListObjAppendElement(interp, resObj, childrenObj);
+
+ Tcl_SetObjResult(interp, resObj);
+ 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)GetSystemDefaultLCID()));
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */