+++ /dev/null
-/*
- * 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;
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-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;
-}
-
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- * 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;
-
-}
-\f
-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;
-
- 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);
- textObj = Tcl_NewUnicodeObj((LPCWSTR)buf, cch);
-
- 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;
-}
-\f
-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;
-}
-\f
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
OSDN Git Service
