/*
* 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:
*/