summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--win/tkWinTest.c113
1 files changed, 105 insertions, 8 deletions
diff --git a/win/tkWinTest.c b/win/tkWinTest.c
index 5df298b..bc84e85 100644
--- a/win/tkWinTest.c
+++ b/win/tkWinTest.c
@@ -6,11 +6,12 @@
*
* 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.
*
- * RCS: @(#) $Id: tkWinTest.c,v 1.4 2000/05/11 23:53:46 hobbs Exp $
+ * RCS: @(#) $Id: tkWinTest.c,v 1.5 2001/10/01 21:20:36 hobbs Exp $
*/
#include "tkWinInt.h"
@@ -65,6 +66,91 @@ TkplatformtestInit(
/*
*----------------------------------------------------------------------
*
+ * 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;
+ 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
+ | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) &wMsgPtr,
+ 0, NULL);
+ if (length == 0) {
+ char *msgPtr;
+
+ length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM
+ | 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) {
+ msg = "function not supported under Win32s";
+ } else {
+ sprintf(msgBuf, "unknown error: %ld", error);
+ msg = msgBuf;
+ }
+ } else {
+ Tcl_Encoding encoding;
+
+ encoding = Tcl_GetEncoding(NULL, "unicode");
+ Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
+ Tcl_FreeEncoding(encoding);
+ LocalFree(wMsgPtr);
+
+ msg = 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 (msg[length-1] == '\r') {
+ msg[--length] = 0;
+ }
+ }
+
+ sprintf(id, "%ld", error);
+ Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL);
+ Tcl_AppendToObj(resultPtr, msg, length);
+
+ if (length != 0) {
+ Tcl_DStringFree(&ds);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestclipboardObjCmd --
*
* This procedure implements the testclipboard command. It provides
@@ -114,7 +200,8 @@ TestclipboardObjCmd(clientData, interp, objc, objv)
CloseClipboard();
return code;
} else {
- Tcl_AppendResult(interp, "couldn't open clipboard", (char *) NULL);
+ Tcl_AppendResult(interp, "couldn't open clipboard: ", (char *) NULL);
+ AppendSystemError(interp, GetLastError());
return TCL_ERROR;
}
return TCL_OK;
@@ -144,7 +231,7 @@ TestwineventCmd(clientData, interp, argc, argv)
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
- HWND hwnd;
+ HWND hwnd = 0;
int id;
char *rest;
UINT message;
@@ -160,12 +247,12 @@ TestwineventCmd(clientData, interp, argc, argv)
};
if ((argc == 3) && (strcmp(argv[1], "debug") == 0)) {
- int i;
+ int b;
- if (Tcl_GetBoolean(interp, argv[2], &i) != TCL_OK) {
+ if (Tcl_GetBoolean(interp, argv[2], &b) != TCL_OK) {
return TCL_ERROR;
}
- TkWinDialogDebug(i);
+ TkWinDialogDebug(b);
return TCL_OK;
}
@@ -173,14 +260,24 @@ 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);
- if (rest == argv[2]) {
+ if (rest == argv[1]) {
hwnd = FindWindow(NULL, argv[1]);
if (hwnd == NULL) {
Tcl_SetResult(interp, "no such window", TCL_STATIC);
return TCL_ERROR;
}
- }
+ }
UpdateWindow(hwnd);
id = strtol(argv[2], &rest, 0);