summaryrefslogtreecommitdiffstats
path: root/win/tkWinTest.c
diff options
context:
space:
mode:
Diffstat (limited to 'win/tkWinTest.c')
-rw-r--r--win/tkWinTest.c205
1 files changed, 108 insertions, 97 deletions
diff --git a/win/tkWinTest.c b/win/tkWinTest.c
index d361ad7..d7d4d0f 100644
--- a/win/tkWinTest.c
+++ b/win/tkWinTest.c
@@ -12,6 +12,10 @@
* 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;
@@ -22,21 +26,20 @@ HWND tkWinCurrentDialog;
static int TestclipboardObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
+ Tcl_Obj *const objv[]);
static int TestwineventCmd(ClientData clientData,
- Tcl_Interp *interp, int argc, CONST char **argv);
+ Tcl_Interp *interp, int argc, const char **argv);
static int TestfindwindowObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
+ Tcl_Obj *const objv[]);
static int TestgetwindowinfoObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
+ 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);
+static Tk_GetSelProc SetSelectionResult;
-
/*
*----------------------------------------------------------------------
*
@@ -99,12 +102,16 @@ AppendSystemError(
{
int length;
WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr;
- char *msg;
+ const char *msg;
char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
Tcl_DString ds;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
- length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
+ 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);
@@ -112,6 +119,7 @@ AppendSystemError(
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);
@@ -124,36 +132,41 @@ AppendSystemError(
}
if (length == 0) {
if (error == ERROR_CALL_NOT_IMPLEMENTED) {
- msg = "function not supported under Win32s";
+ strcpy(msgBuf, "function not supported under Win32s");
} else {
sprintf(msgBuf, "unknown error: %ld", error);
- msg = msgBuf;
}
+ msg = msgBuf;
} else {
Tcl_Encoding encoding;
+ char *msgPtr;
encoding = Tcl_GetEncoding(NULL, "unicode");
- msg = Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
+ 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 (msg[length-1] == '\n') {
- msg[--length] = 0;
+ if (msgPtr[length-1] == '\n') {
+ --length;
}
- if (msg[length-1] == '\r') {
- msg[--length] = 0;
+ 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);
@@ -178,44 +191,30 @@ AppendSystemError(
*/
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. */
+ Tcl_Obj *const objv[]) /* Argument values. */
{
- HGLOBAL handle;
- char *data;
- int code = TCL_OK;
+ Tk_Window tkwin = (Tk_Window) clientData;
if (objc != 1) {
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
- */
-
- handle = GetClipboardData(CF_TEXT);
- if (handle != NULL) {
- data = GlobalLock(handle);
- Tcl_AppendResult(interp, data, NULL);
- GlobalUnlock(handle);
- } else {
- Tcl_AppendResult(interp, "null clipboard handle", NULL);
- code = TCL_ERROR;
- }
- CloseClipboard();
- return code;
- } else {
- Tcl_AppendResult(interp, "couldn't open clipboard: ", NULL);
- AppendSystemError(interp, GetLastError());
- return TCL_ERROR;
- }
- return TCL_OK;
+ return TkSelGetSelection(interp, tkwin, Tk_InternAtom(tkwin, "CLIPBOARD"),
+ XA_STRING, SetSelectionResult, NULL);
}
/*
@@ -240,7 +239,7 @@ TestwineventCmd(
ClientData clientData, /* Main window for application. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
- CONST char **argv) /* Argument strings. */
+ const char **argv) /* Argument strings. */
{
HWND hwnd = 0;
HWND child = 0;
@@ -273,9 +272,19 @@ TestwineventCmd(
return TCL_ERROR;
}
- hwnd = (HWND) INT2PTR(strtol(argv[1], &rest, 0));
+#if 0
+ TkpScanWindowId(interp, argv[1], &id);
+ if (
+#ifdef _WIN64
+ (sscanf(string, "0x%p", &number) != 1) &&
+#endif /* _WIN64 */
+ Tcl_GetInt(interp, string, (int *)&number) != TCL_OK) {
+ return TCL_ERROR;
+ }
+#endif
+ hwnd = INT2PTR(strtol(argv[1], &rest, 0));
if (rest == argv[1]) {
- hwnd = FindWindow(NULL, argv[1]);
+ hwnd = FindWindowA(NULL, argv[1]);
if (hwnd == NULL) {
Tcl_SetResult(interp, "no such window", TCL_STATIC);
return TCL_ERROR;
@@ -289,7 +298,7 @@ TestwineventCmd(
child = GetWindow(hwnd, GW_CHILD);
while (child != NULL) {
- SendMessage(child, WM_GETTEXT, (WPARAM) sizeof(buf), (LPARAM) buf);
+ SendMessageA(child, WM_GETTEXT, (WPARAM) sizeof(buf), (LPARAM) buf);
if (strcasecmp(buf, argv[2]) == 0) {
id = GetDlgCtrlID(child);
break;
@@ -318,7 +327,7 @@ TestwineventCmd(
Tcl_DString ds;
char buf[256];
- GetDlgItemText(hwnd, id, buf, 256);
+ GetDlgItemTextA(hwnd, id, buf, 256);
Tcl_ExternalToUtfDString(NULL, buf, -1, &ds);
Tcl_AppendResult(interp, Tcl_DStringValue(&ds), NULL);
Tcl_DStringFree(&ds);
@@ -328,7 +337,7 @@ TestwineventCmd(
Tcl_DString ds;
Tcl_UtfToExternalDString(NULL, argv[4], -1, &ds);
- SetDlgItemText(hwnd, id, Tcl_DStringValue(&ds));
+ SetDlgItemTextA(hwnd, id, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
break;
}
@@ -338,7 +347,7 @@ TestwineventCmd(
wParam = MAKEWPARAM(id, 0);
lParam = (LPARAM)child;
}
- sprintf(buf, "%d", (int) SendMessage(hwnd, message, wParam, lParam));
+ sprintf(buf, "%d", (int) SendMessageA(hwnd, message, wParam, lParam));
Tcl_SetResult(interp, buf, TCL_VOLATILE);
break;
}
@@ -346,7 +355,7 @@ TestwineventCmd(
char buf[TCL_INTEGER_SPACE];
sprintf(buf, "%d",
- (int) SendDlgItemMessage(hwnd, id, message, wParam, lParam));
+ (int) SendDlgItemMessageA(hwnd, id, message, wParam, lParam));
Tcl_SetResult(interp, buf, TCL_VOLATILE);
break;
}
@@ -357,7 +366,7 @@ TestwineventCmd(
/*
* 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
+ * 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.
@@ -370,20 +379,27 @@ TestfindwindowObjCmd(
ClientData clientData, /* Main window for application. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument values. */
+ Tcl_Obj *const objv[]) /* Argument values. */
{
- const char *title = NULL, *class = NULL;
+ const TCHAR *title = NULL, *class = NULL;
+ Tcl_DString titleString, classString;
HWND hwnd = NULL;
int r = TCL_OK;
+ Tcl_DStringInit(&classString);
+ Tcl_DStringInit(&titleString);
+
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);
+
+ title = Tcl_WinUtfToTChar(Tcl_GetString(objv[1]), -1, &titleString);
+ if (objc == 3) {
+ class = Tcl_WinUtfToTChar(Tcl_GetString(objv[2]), -1, &classString);
+ }
+
+ hwnd = FindWindow(class, title);
if (hwnd == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to find window: ", -1));
@@ -392,14 +408,20 @@ TestfindwindowObjCmd(
} else {
Tcl_SetObjResult(interp, Tcl_NewLongObj(PTR2INT(hwnd)));
}
+
+ Tcl_DStringFree(&titleString);
+ Tcl_DStringFree(&classString);
return r;
-
+
}
static BOOL CALLBACK
-EnumChildrenProc(HWND hwnd, LPARAM lParam)
+EnumChildrenProc(
+ HWND hwnd,
+ LPARAM lParam)
{
- Tcl_Obj *listObj = (Tcl_Obj *)lParam;
+ Tcl_Obj *listObj = (Tcl_Obj *) lParam;
+
Tcl_ListObjAppendElement(NULL, listObj, Tcl_NewLongObj(PTR2INT(hwnd)));
return TRUE;
}
@@ -409,13 +431,13 @@ TestgetwindowinfoObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
- Tcl_Obj *CONST objv[])
+ Tcl_Obj *const objv[])
{
long hwnd;
- Tcl_Obj *resObj = NULL, *classObj = NULL, *textObj = NULL;
+ Tcl_Obj *dictObj = NULL, *classObj = NULL, *textObj = NULL;
Tcl_Obj *childrenObj = NULL;
- char buf[512];
- int cch, cchBuf = tkWinProcs->useWide ? 256 : 512;
+ TCHAR buf[512];
+ int cch, cchBuf = 256;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "hwnd");
@@ -424,49 +446,38 @@ TestgetwindowinfoObjCmd(
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);
- }
+
+ cch = GetClassName(INT2PTR(hwnd), buf, cchBuf);
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_DString ds;
+ Tcl_WinTCharToUtf(buf, -1, &ds);
+ classObj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
}
- 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)))));
+ 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_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("children", -1));
- Tcl_ListObjAppendElement(interp, resObj, childrenObj);
+ Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("children", -1), childrenObj);
- Tcl_SetObjResult(interp, resObj);
+ Tcl_SetObjResult(interp, dictObj);
return TCL_OK;
-}
+}
static int
TestwinlocaleObjCmd(
@@ -479,7 +490,7 @@ TestwinlocaleObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj((int)GetSystemDefaultLCID()));
+ Tcl_SetObjResult(interp, Tcl_NewIntObj((int)GetThreadLocale()));
return TCL_OK;
}