summaryrefslogtreecommitdiffstats
path: root/win
diff options
context:
space:
mode:
Diffstat (limited to 'win')
-rwxr-xr-xwin/configure8
-rw-r--r--win/configure.in8
-rw-r--r--win/makefile.bc8
-rw-r--r--win/makefile.vc4
-rw-r--r--win/rules.vc8
-rw-r--r--win/tclWinDde.c433
-rw-r--r--win/tclWinReg.c639
7 files changed, 687 insertions, 421 deletions
diff --git a/win/configure b/win/configure
index 51a86a7..0f36f24 100755
--- a/win/configure
+++ b/win/configure
@@ -541,14 +541,14 @@ TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL=".19"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-TCL_DDE_VERSION=1.2
+TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
-TCL_DDE_MINOR_VERSION=2
+TCL_DDE_MINOR_VERSION=3
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
-TCL_REG_VERSION=1.1
+TCL_REG_VERSION=1.2
TCL_REG_MAJOR_VERSION=1
-TCL_REG_MINOR_VERSION=1
+TCL_REG_MINOR_VERSION=2
REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION
#------------------------------------------------------------------------
diff --git a/win/configure.in b/win/configure.in
index 635469b..99dc334 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -12,14 +12,14 @@ TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL=".19"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-TCL_DDE_VERSION=1.2
+TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
-TCL_DDE_MINOR_VERSION=2
+TCL_DDE_MINOR_VERSION=3
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
-TCL_REG_VERSION=1.1
+TCL_REG_VERSION=1.2
TCL_REG_MAJOR_VERSION=1
-TCL_REG_MINOR_VERSION=1
+TCL_REG_MINOR_VERSION=2
REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION
#------------------------------------------------------------------------
diff --git a/win/makefile.bc b/win/makefile.bc
index 3c0ea73..6a3cd9d 100644
--- a/win/makefile.bc
+++ b/win/makefile.bc
@@ -110,11 +110,11 @@ STUBPREFIX = $(NAMEPREFIX)stub
DOTVERSION = 8.4
VERSION = 84
-DDEVERSION = 12
-DDEDOTVERSION = 1.2
+DDEVERSION = 13
+DDEDOTVERSION = 1.3
-REGVERSION = 11
-REGDOTVERSION = 1.1
+REGVERSION = 12
+REGDOTVERSION = 1.2
BINROOT = ..
!IF "$(NODEBUG)" == "1"
diff --git a/win/makefile.vc b/win/makefile.vc
index 94a585b..41a0006 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -159,10 +159,10 @@ STUBPREFIX = $(PROJECT)stub
DOTVERSION = 8.4
VERSION = $(DOTVERSION:.=)
-DDEDOTVERSION = 1.2
+DDEDOTVERSION = 1.3
DDEVERSION = $(DDEDOTVERSION:.=)
-REGDOTVERSION = 1.1
+REGDOTVERSION = 1.2
REGVERSION = $(REGDOTVERSION:.=)
BINROOT = .
diff --git a/win/rules.vc b/win/rules.vc
index 425f5fb..38e8175 100644
--- a/win/rules.vc
+++ b/win/rules.vc
@@ -477,8 +477,8 @@ TCLSH = "$(_INSTALLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe"
TCLSTUBLIB = "$(_INSTALLDIR)\lib\tclstub$(TCL_VERSION).lib"
TCLIMPLIB = "$(_INSTALLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib"
TCL_LIBRARY = $(_INSTALLDIR)\lib
-TCLREGLIB = "$(_INSTALLDIR)\lib\tclreg11$(SUFX:t=).lib"
-TCLDDELIB = "$(_INSTALLDIR)\lib\tcldde12$(SUFX:t=).lib"
+TCLREGLIB = "$(_INSTALLDIR)\lib\tclreg12$(SUFX:t=).lib"
+TCLDDELIB = "$(_INSTALLDIR)\lib\tcldde13$(SUFX:t=).lib"
COFFBASE = \must\have\tcl\sources\to\build\this\target
TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target
!else
@@ -486,8 +486,8 @@ TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX).exe"
TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib"
TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib"
TCL_LIBRARY = $(_TCLDIR)\library
-TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg11$(SUFX:t=).lib"
-TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde12$(SUFX:t=).lib"
+TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg12$(SUFX:t=).lib"
+TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde13$(SUFX:t=).lib"
COFFBASE = "$(_TCLDIR)\win\coffbase.txt"
TCLTOOLSDIR = $(_TCLDIR)\tools
!endif
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index 4aa6f71..eef5caa 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -10,6 +10,7 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#include "tclInt.h"
#include "tclPort.h"
#include <dde.h>
#include <ddeml.h>
@@ -34,6 +35,7 @@ typedef struct RegisteredInterp {
/* The next interp this application knows
* about. */
char *name; /* Interpreter's name (malloc-ed). */
+ Tcl_Obj *handlerPtr; /* The server handler command */
Tcl_Interp *interp; /* The interpreter attached to this name. */
} RegisteredInterp;
@@ -49,6 +51,14 @@ typedef struct Conversation {
Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
} Conversation;
+typedef struct DdeEnumServices {
+ Tcl_Interp *interp;
+ int result;
+ ATOM service;
+ ATOM topic;
+ HWND hwnd;
+} DdeEnumServices;
+
typedef struct ThreadSpecificData {
Conversation *currentConversations;
/* A list of conversations currently being
@@ -69,23 +79,33 @@ static DWORD ddeInstance; /* The application instance handle given to us
* by DdeInitialize. */
static int ddeIsServer = 0;
-#define TCL_DDE_VERSION "1.2.5"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME "TclEval"
#define TCL_DDE_EXECUTE_RESULT "$TCLEVAL$EXECUTE$RESULT"
+#define DDE_FLAG_ASYNC 1
+#define DDE_FLAG_BINARY 2
+#define DDE_FLAG_FORCE 4
+
TCL_DECLARE_MUTEX(ddeMutex)
/*
* Forward declarations for functions defined later in this file.
*/
+static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg,
+ WPARAM wParam, LPARAM lParam);
+static int DdeCreateClient(struct DdeEnumServices *es);
+static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget,
+ LPARAM lParam);
static void DdeExitProc(ClientData clientData);
static int DdeGetServicesList(Tcl_Interp *interp,
const char *serviceName, const char *topicName);
static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv,
HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData,
DWORD dwData1, DWORD dwData2);
+static LRESULT DdeServicesOnAck(HWND hwnd, WPARAM wParam,
+ LPARAM lParam);
static void DeleteProc(ClientData clientData);
static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr,
Tcl_Obj *ddeObjectPtr);
@@ -97,6 +117,7 @@ static int DdeObjCmd(ClientData clientData,
Tcl_Obj *const objv[]);
EXTERN int Dde_Init(Tcl_Interp *interp);
+EXTERN int Dde_SafeInit(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
@@ -124,7 +145,34 @@ Dde_Init(
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL);
Tcl_CreateExitHandler(DdeExitProc, NULL);
- return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
+ return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, "1.3.3");
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Dde_SafeInit --
+ *
+ * This function initializes the dde command within a safe interp
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Dde_SafeInit(
+ Tcl_Interp *interp)
+{
+ int result = Dde_Init(interp);
+ if (result == TCL_OK) {
+ Tcl_HideCommand(interp, "dde", "dde");
+ }
+ return result;
}
/*
@@ -181,7 +229,7 @@ Initialize(void)
ddeIsServer = 1;
Tcl_CreateExitHandler(DdeExitProc, NULL);
ddeServiceGlobal = DdeCreateStringHandle(ddeInstance,
- TCL_DDE_SERVICE_NAME, CP_WINANSI);
+ TCL_DDE_SERVICE_NAME, 0);
DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
} else {
ddeIsServer = 0;
@@ -218,13 +266,19 @@ Initialize(void)
static const char *
DdeSetServerName(
Tcl_Interp *interp,
- const char *name /* The name that will be used to refer to the
+ const char *name, /* The name that will be used to refer to the
* interpreter in later "send" commands. Must
* be globally unique. */
- )
+ int flags, /* DDE_FLAG_FORCE or 0 */
+ Tcl_Obj *handlerPtr) /* Name of the optional proc/command to handle
+ * incoming Dde eval's */
{
+ int suffix, offset;
RegisteredInterp *riPtr, *prevPtr;
Tcl_DString dString;
+ const char *actualName;
+ Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
+ int n, srvCount = 0, lastSuffix, r = TCL_OK;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
@@ -263,7 +317,67 @@ DdeSetServerName(
return "";
}
+ /*
+ * Get the list of currently registered Tcl interpreters by calling the
+ * internal implementation of the 'dde services' command.
+ */
+
Tcl_DStringInit(&dString);
+ actualName = name;
+
+ if (!(flags & DDE_FLAG_FORCE)) {
+ r = DdeGetServicesList(interp, TCL_DDE_SERVICE_NAME, NULL);
+ if (r == TCL_OK) {
+ srvListPtr = Tcl_GetObjResult(interp);
+ }
+ if (r == TCL_OK) {
+ r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount,
+ &srvPtrPtr);
+ }
+ if (r != TCL_OK) {
+ OutputDebugString(Tcl_GetStringResult(interp));
+ return NULL;
+ }
+
+ /*
+ * Pick a name to use for the application. Use "name" if it's not
+ * already in use. Otherwise add a suffix such as " #2", trying larger
+ * and larger numbers until we eventually find one that is unique.
+ */
+
+ offset = lastSuffix = 0;
+ suffix = 1;
+
+ while (suffix != lastSuffix) {
+ lastSuffix = suffix;
+ if (suffix > 1) {
+ if (suffix == 2) {
+ Tcl_DStringAppend(&dString, name, -1);
+ Tcl_DStringAppend(&dString, " #", 2);
+ offset = Tcl_DStringLength(&dString);
+ Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE);
+ actualName = Tcl_DStringValue(&dString);
+ }
+ sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
+ }
+
+ /*
+ * See if the name is already in use, if so increment suffix.
+ */
+
+ for (n = 0; n < srvCount; ++n) {
+ Tcl_Obj* namePtr;
+
+ Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
+ if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) {
+ suffix++;
+ break;
+ }
+ }
+ }
+ Tcl_DStringSetLength(&dString,
+ offset + (int)strlen(Tcl_DStringValue(&dString)+offset));
+ }
/*
* We have found a unique name. Now add it to the registry.
@@ -271,10 +385,18 @@ DdeSetServerName(
riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
- riPtr->name = ckalloc((unsigned int) strlen(name) + 1);
+ riPtr->name = ckalloc((unsigned int) strlen(actualName) + 1);
riPtr->nextPtr = tsdPtr->interpListPtr;
+ riPtr->handlerPtr = handlerPtr;
+ if (riPtr->handlerPtr != NULL) {
+ Tcl_IncrRefCount(riPtr->handlerPtr);
+ }
tsdPtr->interpListPtr = riPtr;
- strcpy(riPtr->name, name);
+ strcpy(riPtr->name, actualName);
+
+ if (Tcl_IsSafe(interp)) {
+ Tcl_ExposeCommand(interp, "dde", "dde");
+ }
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd,
(ClientData) riPtr, DeleteProc);
@@ -295,6 +417,38 @@ DdeSetServerName(
/*
*----------------------------------------------------------------------
*
+ * DdeGetRegistrationPtr
+ *
+ * Retrieve the registration info for an interpreter.
+ *
+ * Results:
+ * Returns a pointer to the registration structure or NULL
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+static RegisteredInterp *
+DdeGetRegistrationPtr(
+ Tcl_Interp *interp)
+{
+ RegisteredInterp *riPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
+ riPtr = riPtr->nextPtr) {
+ if (riPtr->interp == interp) {
+ break;
+ }
+ }
+ return riPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* DeleteProc
*
* This function is called when the command "dde" is destroyed.
@@ -333,6 +487,9 @@ DeleteProc(
}
}
ckfree(riPtr->name);
+ if (riPtr->handlerPtr) {
+ Tcl_DecrRefCount(riPtr->handlerPtr);
+ }
Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
}
@@ -365,10 +522,35 @@ ExecuteRemoteObject(
Tcl_Obj *ddeObjectPtr) /* The object to execute. */
{
Tcl_Obj *returnPackagePtr;
- int result;
+ int result = TCL_OK;
+
+ if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) {
+ Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
+ "a handler procedure must be defined for use in a safe "
+ "interp", -1));
+ result = TCL_ERROR;
+ }
+
+ if (riPtr->handlerPtr != NULL) {
+ /*
+ * Add the dde request data to the handler proc list.
+ */
+
+ Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr);
+
+ result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr,
+ ddeObjectPtr);
+ if (result == TCL_OK) {
+ ddeObjectPtr = cmdPtr;
+ }
+ }
+
+ if (result == TCL_OK) {
+ result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
+ }
+
+ returnPackagePtr = Tcl_NewListObj(0, NULL);
- result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
- returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, returnPackagePtr,
Tcl_NewIntObj(result));
Tcl_ListObjAppendElement(NULL, returnPackagePtr,
@@ -549,21 +731,27 @@ DdeServerProc(
ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString,
(DWORD) len+1, 0, ddeItem, uFmt, 0);
} else {
- Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
- convPtr->riPtr->interp, utilString, NULL,
- TCL_GLOBAL_ONLY);
- if (variableObjPtr != NULL) {
- if (uFmt == CF_TEXT) {
- returnString = Tcl_GetStringFromObj(variableObjPtr, &len);
+ if (Tcl_IsSafe(convPtr->riPtr->interp)) {
+ ddeReturn = NULL;
+ } else {
+ Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
+ convPtr->riPtr->interp, utilString, NULL,
+ TCL_GLOBAL_ONLY);
+ if (variableObjPtr != NULL) {
+ if (uFmt == CF_TEXT) {
+ returnString = Tcl_GetStringFromObj(
+ variableObjPtr, &len);
+ } else {
+ returnString = (char *) Tcl_GetUnicodeFromObj(
+ variableObjPtr, &len);
+ len = 2 * len + 1;
+ }
+ ddeReturn = DdeCreateDataHandle(ddeInstance,
+ (BYTE *)returnString, (DWORD) len+1, 0, ddeItem,
+ uFmt, 0);
} else {
- returnString = (char *)
- Tcl_GetUnicodeFromObj(variableObjPtr, &len);
- len = 2 * len + 1;
+ ddeReturn = NULL;
}
- ddeReturn = DdeCreateDataHandle(ddeInstance,
- (BYTE *) returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0);
- } else {
- ddeReturn = NULL;
}
}
Tcl_DStringFree(&dString);
@@ -723,8 +911,8 @@ MakeDdeConnection(
HSZ ddeTopic, ddeService;
HCONV ddeConv;
- ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINANSI);
- ddeTopic = DdeCreateStringHandle(ddeInstance, name, CP_WINANSI);
+ ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, 0);
+ ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
@@ -762,21 +950,9 @@ MakeDdeConnection(
*----------------------------------------------------------------------
*/
-typedef struct ddeEnumServices {
- Tcl_Interp *interp;
- int result;
- ATOM service;
- ATOM topic;
- HWND hwnd;
-} ddeEnumServices;
-
-static LRESULT CALLBACK
-DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam);
-static LRESULT
-DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam);
-
static int
-DdeCreateClient(ddeEnumServices *es)
+DdeCreateClient(
+ struct DdeEnumServices *es)
{
WNDCLASSEX wc;
static const char *szDdeClientClassName = "TclEval client class";
@@ -786,7 +962,7 @@ DdeCreateClient(ddeEnumServices *es)
wc.cbSize = sizeof(wc);
wc.lpfnWndProc = DdeClientWindowProc;
wc.lpszClassName = szDdeClientClassName;
- wc.cbWndExtra = sizeof(ddeEnumServices*);
+ wc.cbWndExtra = sizeof(struct DdeEnumServices *);
/*
* Register and create the callback window.
@@ -808,8 +984,9 @@ DdeClientWindowProc(
switch (uMsg) {
case WM_CREATE: {
LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam;
- ddeEnumServices *es =
- (ddeEnumServices*) lpcs->lpCreateParams;
+ struct DdeEnumServices *es =
+ (struct DdeEnumServices *) lpcs->lpCreateParams;
+
#ifdef _WIN64
SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es);
#else
@@ -833,25 +1010,24 @@ DdeServicesOnAck(
HWND hwndRemote = (HWND)wParam;
ATOM service = (ATOM)LOWORD(lParam);
ATOM topic = (ATOM)HIWORD(lParam);
- ddeEnumServices *es;
+ struct DdeEnumServices *es;
char sz[255];
#ifdef _WIN64
- es = (ddeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
+ es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
- es = (ddeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA);
+ es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA);
#endif
if ((es->service == (ATOM)0 || es->service == service)
&& (es->topic == (ATOM)0 || es->topic == topic)) {
Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
+ Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);
GlobalGetAtomName(service, sz, 255);
- Tcl_ListObjAppendElement(es->interp, matchPtr,
- Tcl_NewStringObj(sz, -1));
+ Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));
GlobalGetAtomName(topic, sz, 255);
- Tcl_ListObjAppendElement(es->interp, matchPtr,
- Tcl_NewStringObj(sz, -1));
+ Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));
/*
* Adding the hwnd as a third list element provides a unique
@@ -864,8 +1040,13 @@ DdeServicesOnAck(
* Tcl_NewLongObj((long)hwndRemote));
*/
- Tcl_ListObjAppendElement(es->interp,
- Tcl_GetObjResult(es->interp), matchPtr);
+ if (Tcl_IsShared(resultPtr)) {
+ resultPtr = Tcl_DuplicateObj(resultPtr);
+ }
+ if (Tcl_ListObjAppendElement(es->interp, resultPtr,
+ matchPtr) == TCL_OK) {
+ Tcl_SetObjResult(es->interp, resultPtr);
+ }
}
/*
@@ -882,7 +1063,7 @@ DdeEnumWindowsCallback(
LPARAM lParam)
{
DWORD_PTR dwResult = 0;
- ddeEnumServices *es = (ddeEnumServices *) lParam;
+ struct DdeEnumServices *es = (struct DdeEnumServices *) lParam;
SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd,
MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000,
@@ -896,7 +1077,7 @@ DdeGetServicesList(
const char *serviceName,
const char *topicName)
{
- ddeEnumServices es;
+ struct DdeEnumServices es;
es.interp = interp;
es.result = TCL_OK;
@@ -989,10 +1170,16 @@ DdeObjCmd(
static const char *ddeCommands[] = {
"servername", "execute", "poke", "request", "services", "eval",
(char *) NULL};
- enum {
+ enum DdeSubcommands {
DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES,
DDE_EVAL
};
+ static const char *ddeSrvOptions[] = {
+ "-force", "-handler", "--", NULL
+ };
+ enum DdeSrvOptions {
+ DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST,
+ };
static const char *ddeExecOptions[] = {
"-async", NULL
};
@@ -1000,15 +1187,14 @@ DdeObjCmd(
"-binary", NULL
};
- int index, length, argIndex;
- int async = 0, binary = 0;
- int result = TCL_OK, firstArg = 0;
+ int index, i, length, argIndex;
+ int flags = 0, result = TCL_OK, firstArg = 0;
HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
HCONV hConv = NULL;
const char *serviceName = NULL, *topicName = NULL, *string;
DWORD ddeResult;
- Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr, *handlerPtr = NULL;
/*
* Initialize DDE server/client
@@ -1024,24 +1210,59 @@ DdeObjCmd(
return TCL_ERROR;
}
- switch (index) {
+ switch ((enum DdeSubcommands) index) {
case DDE_SERVERNAME:
- if ((objc != 3) && (objc != 2)) {
- Tcl_WrongNumArgs(interp, 1, objv, "servername ?serverName?");
+ for (i = 2; i < objc; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions,
+ "option", 0, &argIndex) != TCL_OK) {
+ /*
+ * If it is the last argument, it might be a server name
+ * instead of a bad argument.
+ */
+
+ if (i != objc-1) {
+ return TCL_ERROR;
+ }
+ Tcl_ResetResult(interp);
+ break;
+ }
+ if (argIndex == DDE_SERVERNAME_EXACT) {
+ flags |= DDE_FLAG_FORCE;
+ } else if (argIndex == DDE_SERVERNAME_HANDLER) {
+ if ((objc - i) == 1) { /* return current handler */
+ RegisteredInterp *riPtr = DdeGetRegistrationPtr(interp);
+
+ if (riPtr && riPtr->handlerPtr) {
+ Tcl_SetObjResult(interp, riPtr->handlerPtr);
+ } else {
+ Tcl_ResetResult(interp);
+ }
+ return TCL_OK;
+ }
+ handlerPtr = objv[++i];
+ } else if (argIndex == DDE_SERVERNAME_LAST) {
+ i++;
+ break;
+ }
+ }
+
+ if ((objc - i) > 1) {
+ Tcl_ResetResult(interp);
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-force? ?-handler proc? ?--? ?serverName?");
return TCL_ERROR;
}
- firstArg = (objc - 1);
+ firstArg = (objc == i) ? 1 : i;
break;
case DDE_EXECUTE:
if (objc == 5) {
firstArg = 2;
break;
} else if (objc == 6) {
- int dummy;
if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0,
- &dummy) == TCL_OK) {
- async = 1;
+ &argIndex) == TCL_OK) {
+ flags |= DDE_FLAG_ASYNC;
firstArg = 3;
break;
}
@@ -1066,7 +1287,7 @@ DdeObjCmd(
int dummy;
if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
&dummy) == TCL_OK) {
- binary = 1;
+ flags |= DDE_FLAG_BINARY;
firstArg = 3;
break;
}
@@ -1098,7 +1319,7 @@ DdeObjCmd(
if (objc < 5) {
goto wrongDdeEvalArgs;
}
- async = 1;
+ flags |= DDE_FLAG_ASYNC;
firstArg++;
}
break;
@@ -1130,9 +1351,10 @@ DdeObjCmd(
}
}
- switch (index) {
+ switch ((enum DdeSubcommands) index) {
case DDE_SERVERNAME:
- serviceName = DdeSetServerName(interp, serviceName);
+ serviceName = DdeSetServerName(interp, serviceName, flags,
+ handlerPtr);
if (serviceName != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1));
} else {
@@ -1152,12 +1374,8 @@ DdeObjCmd(
break;
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
- if (ddeService) {
- DdeFreeStringHandle(ddeInstance, ddeService);
- }
- if (ddeTopic) {
- DdeFreeStringHandle(ddeInstance, ddeTopic);
- }
+ DdeFreeStringHandle(ddeInstance, ddeService);
+ DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
@@ -1168,7 +1386,7 @@ DdeObjCmd(
ddeData = DdeCreateDataHandle(ddeInstance, dataString,
(DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
if (ddeData != NULL) {
- if (async) {
+ if (flags & DDE_FLAG_ASYNC) {
DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
@@ -1198,12 +1416,8 @@ DdeObjCmd(
goto cleanup;
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
- if (ddeService) {
- DdeFreeStringHandle(ddeInstance, ddeService);
- }
- if (ddeTopic) {
- DdeFreeStringHandle(ddeInstance, ddeTopic);
- }
+ DdeFreeStringHandle(ddeInstance, ddeService);
+ DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
@@ -1222,9 +1436,9 @@ DdeObjCmd(
DWORD tmp;
const char *dataString = (const char *) DdeAccessData(ddeData, &tmp);
- if (binary) {
- returnObjPtr = Tcl_NewByteArrayObj((BYTE *) dataString,
- (int) tmp);
+ if (flags & DDE_FLAG_BINARY) {
+ returnObjPtr =
+ Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp);
} else {
if (tmp && !dataString[tmp-1]) {
--tmp;
@@ -1259,12 +1473,8 @@ DdeObjCmd(
&length);
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
- if (ddeService) {
DdeFreeStringHandle(ddeInstance, ddeService);
- }
- if (ddeTopic) {
DdeFreeStringHandle(ddeInstance, ddeTopic);
- }
if (hConv == NULL) {
SetDdeError(interp);
@@ -1302,8 +1512,8 @@ DdeObjCmd(
goto cleanup;
}
- objc -= (async + 3);
- objv += (async + 3);
+ objc -= firstArg + 1;
+ objv += firstArg + 1;
/*
* See if the target interpreter is local. If so, execute the command
@@ -1341,11 +1551,34 @@ DdeObjCmd(
* referring to deallocated objects.
*/
- if (objc == 1) {
- result = Tcl_EvalObjEx(sendInterp, objv[0],
- TCL_EVAL_GLOBAL);
- } else {
- objPtr = Tcl_ConcatObj(objc, objv);
+ if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
+ Tcl_SetResult(riPtr->interp, "permission denied: "
+ "a handler procedure must be defined for use in "
+ "a safe interp", TCL_STATIC);
+ result = TCL_ERROR;
+ }
+
+ if (result == TCL_OK) {
+ if (objc == 1)
+ objPtr = objv[0];
+ else {
+ objPtr = Tcl_ConcatObj(objc, objv);
+ }
+ if (riPtr->handlerPtr != NULL) {
+ /* add the dde request data to the handler proc list */
+ /*
+ *result = Tcl_ListObjReplace(sendInterp, objPtr, 0, 0, 1,
+ * &(riPtr->handlerPtr));
+ */
+ Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr);
+ result = Tcl_ListObjAppendElement(sendInterp, cmdPtr,
+ objPtr);
+ if (result == TCL_OK) {
+ objPtr = cmdPtr;
+ }
+ }
+ }
+ if (result == TCL_OK) {
Tcl_IncrRefCount(objPtr);
result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(objPtr);
@@ -1384,7 +1617,8 @@ DdeObjCmd(
if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
invalidServerResponse:
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("invalid data returned from server", -1));
+ Tcl_NewStringObj("invalid data returned from server",
+ -1));
result = TCL_ERROR;
goto cleanup;
}
@@ -1394,7 +1628,7 @@ DdeObjCmd(
ddeItemData = DdeCreateDataHandle(ddeInstance,
(BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0);
- if (async) {
+ if (flags & DDE_FLAG_ASYNC) {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
@@ -1416,10 +1650,9 @@ DdeObjCmd(
if (ddeData == 0) {
SetDdeError(interp);
result = TCL_ERROR;
- goto cleanup;
}
- if (async == 0) {
+ if (!(flags & DDE_FLAG_ASYNC)) {
Tcl_Obj *resultPtr;
/*
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index 701edfb..a6ce2ce 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -1,18 +1,22 @@
/*
* tclWinReg.c --
*
- * This file contains the implementation of the "registry" Tcl
- * built-in command. This command is built as a dynamically
- * loadable extension in a separate DLL.
+ * This file contains the implementation of the "registry" Tcl built-in
+ * command. This command is built as a dynamically loadable extension in
+ * a separate DLL.
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics 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 <tclPort.h>
+#include "tclInt.h"
+#include "tclPort.h"
+#ifdef _MSC_VER
+# pragma comment (lib, "advapi32.lib")
+#endif
#include <stdlib.h>
/*
@@ -25,6 +29,14 @@
#define TCL_STORAGE_CLASS DLLEXPORT
/*
+ * The maximum length of a sub-key name.
+ */
+
+#ifndef MAX_KEY_LENGTH
+#define MAX_KEY_LENGTH 256
+#endif
+
+/*
* The following macros convert between different endian ints.
*/
@@ -32,15 +44,15 @@
#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
/*
- * The following flag is used in OpenKeys to indicate that the specified
- * key should be created if it doesn't currently exist.
+ * The following flag is used in OpenKeys to indicate that the specified key
+ * should be created if it doesn't currently exist.
*/
#define REG_CREATE 1
/*
- * The following tables contain the mapping from registry root names
- * to the system predefined keys.
+ * The following tables contain the mapping from registry root names to the
+ * system predefined keys.
*/
static CONST char *rootKeyNames[] = {
@@ -54,11 +66,12 @@ static const HKEY rootKeys[] = {
HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
};
+static CONST char REGISTRY_ASSOC_KEY[] = "registry::command";
+
/*
- * The following table maps from registry types to strings. Note that
- * the indices for this array are the same as the constants for the
- * known registry types so we don't need a separate table to hold the
- * mapping.
+ * The following table maps from registry types to strings. Note that the
+ * indices for this array are the same as the constants for the known registry
+ * types so we don't need a separate table to hold the mapping.
*/
static CONST char *typeNames[] = {
@@ -70,9 +83,9 @@ static DWORD lastType = REG_RESOURCE_LIST;
/*
* The following structures allow us to select between the Unicode and ASCII
- * interfaces at run time based on whether Unicode APIs are available. The
- * Unicode APIs are preferable because they will handle characters outside
- * of the current code page.
+ * interfaces at run time based on whether Unicode APIs are available. The
+ * Unicode APIs are preferable because they will handle characters outside of
+ * the current code page.
*/
typedef struct RegWinProcs {
@@ -80,7 +93,7 @@ typedef struct RegWinProcs {
LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY);
LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
- DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
+ DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);
LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *);
LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD);
@@ -90,9 +103,6 @@ typedef struct RegWinProcs {
DWORD *, BYTE *, DWORD *);
LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM,
HKEY *);
- LONG (WINAPI *regQueryInfoKeyProc)(HKEY, TCHAR *, DWORD *, DWORD *,
- DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
- FILETIME *);
LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
BYTE *, DWORD *);
LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD,
@@ -107,7 +117,7 @@ static RegWinProcs asciiProcs = {
(LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
(LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
- DWORD *)) RegCreateKeyExA,
+ DWORD *)) RegCreateKeyExA,
(LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA,
(LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA,
(LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA,
@@ -117,9 +127,6 @@ static RegWinProcs asciiProcs = {
DWORD *, BYTE *, DWORD *)) RegEnumValueA,
(LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
HKEY *)) RegOpenKeyExA,
- (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *,
- DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
- FILETIME *)) RegQueryInfoKeyA,
(LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
BYTE *, DWORD *)) RegQueryValueExA,
(LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
@@ -132,7 +139,7 @@ static RegWinProcs unicodeProcs = {
(LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
(LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
- DWORD *)) RegCreateKeyExW,
+ DWORD *)) RegCreateKeyExW,
(LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW,
(LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW,
(LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW,
@@ -142,9 +149,6 @@ static RegWinProcs unicodeProcs = {
DWORD *, BYTE *, DWORD *)) RegEnumValueW,
(LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
HKEY *)) RegOpenKeyExW,
- (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *,
- DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
- FILETIME *)) RegQueryInfoKeyW,
(LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
BYTE *, DWORD *)) RegQueryValueExW,
(LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
@@ -160,6 +164,7 @@ static void AppendSystemError(Tcl_Interp *interp, DWORD error);
static int BroadcastValue(Tcl_Interp *interp, int objc,
Tcl_Obj * CONST objv[]);
static DWORD ConvertDWORD(DWORD type, DWORD value);
+static void DeleteCmd(ClientData clientData);
static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);
static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj);
@@ -188,14 +193,15 @@ static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
Tcl_Obj *typeObj);
-EXTERN int Registry_Init(Tcl_Interp *interp);
+EXTERN int Registry_Init(Tcl_Interp *interp);
+EXTERN int Registry_Unload(Tcl_Interp *interp, int flags);
/*
*----------------------------------------------------------------------
*
* Registry_Init --
*
- * This procedure initializes the registry command.
+ * This function initializes the registry command.
*
* Results:
* A standard Tcl result.
@@ -210,7 +216,9 @@ int
Registry_Init(
Tcl_Interp *interp)
{
- if (!Tcl_InitStubs(interp, "8.0", 0)) {
+ Tcl_Command cmd;
+
+ if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
return TCL_ERROR;
}
@@ -225,8 +233,80 @@ Registry_Init(
regWinProcs = &asciiProcs;
}
- Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);
- return Tcl_PkgProvide(interp, "registry", "1.1.5");
+ cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
+ (ClientData)interp, DeleteCmd);
+ Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)cmd);
+ return Tcl_PkgProvide(interp, "registry", "1.2.2");
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Registry_Unload --
+ *
+ * This function removes the registry command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * The registry command is deleted and the dll may be unloaded.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Registry_Unload(
+ Tcl_Interp *interp, /* Interpreter for unloading */
+ int flags) /* Flags passed by the unload system */
+{
+ Tcl_Command cmd;
+ Tcl_Obj *objv[3];
+
+ /*
+ * Unregister the registry package. There is no Tcl_PkgForget()
+ */
+
+ objv[0] = Tcl_NewStringObj("package", -1);
+ objv[1] = Tcl_NewStringObj("forget", -1);
+ objv[2] = Tcl_NewStringObj("registry", -1);
+ Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL);
+
+ /*
+ * Delete the originally registered command.
+ */
+
+ cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL);
+ if (cmd != NULL) {
+ Tcl_DeleteCommandFromToken(interp, cmd);
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteCmd --
+ *
+ * Cleanup the interp command token so that unloading doesn't try to
+ * re-delete the command (which will crash).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The unload command will not attempt to delete this command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteCmd(
+ ClientData clientData)
+{
+ Tcl_Interp *interp = clientData;
+ Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)NULL);
}
/*
@@ -256,8 +336,7 @@ RegistryObjCmd(
char *errString = NULL;
static CONST char *subcommands[] = {
- "broadcast", "delete", "get", "keys", "set", "type", "values",
- (char *) NULL
+ "broadcast", "delete", "get", "keys", "set", "type", "values", NULL
};
enum SubCmdIdx {
BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx
@@ -274,65 +353,64 @@ RegistryObjCmd(
}
switch (index) {
- case BroadcastIdx: /* broadcast */
- return BroadcastValue(interp, objc, objv);
- break;
- case DeleteIdx: /* delete */
- if (objc == 3) {
- return DeleteKey(interp, objv[2]);
- } else if (objc == 4) {
- return DeleteValue(interp, objv[2], objv[3]);
- }
- errString = "keyName ?valueName?";
- break;
- case GetIdx: /* get */
- if (objc == 4) {
- return GetValue(interp, objv[2], objv[3]);
- }
- errString = "keyName valueName";
- break;
- case KeysIdx: /* keys */
- if (objc == 3) {
- return GetKeyNames(interp, objv[2], NULL);
- } else if (objc == 4) {
- return GetKeyNames(interp, objv[2], objv[3]);
- }
- errString = "keyName ?pattern?";
- break;
- case SetIdx: /* set */
- if (objc == 3) {
- HKEY key;
+ case BroadcastIdx: /* broadcast */
+ return BroadcastValue(interp, objc, objv);
+ break;
+ case DeleteIdx: /* delete */
+ if (objc == 3) {
+ return DeleteKey(interp, objv[2]);
+ } else if (objc == 4) {
+ return DeleteValue(interp, objv[2], objv[3]);
+ }
+ errString = "keyName ?valueName?";
+ break;
+ case GetIdx: /* get */
+ if (objc == 4) {
+ return GetValue(interp, objv[2], objv[3]);
+ }
+ errString = "keyName valueName";
+ break;
+ case KeysIdx: /* keys */
+ if (objc == 3) {
+ return GetKeyNames(interp, objv[2], NULL);
+ } else if (objc == 4) {
+ return GetKeyNames(interp, objv[2], objv[3]);
+ }
+ errString = "keyName ?pattern?";
+ break;
+ case SetIdx: /* set */
+ if (objc == 3) {
+ HKEY key;
- /*
- * Create the key and then close it immediately.
- */
+ /*
+ * Create the key and then close it immediately.
+ */
- if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key)
- != TCL_OK) {
- return TCL_ERROR;
- }
- RegCloseKey(key);
- return TCL_OK;
- } else if (objc == 5 || objc == 6) {
- Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
- return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
- }
- errString = "keyName ?valueName data ?type??";
- break;
- case TypeIdx: /* type */
- if (objc == 4) {
- return GetType(interp, objv[2], objv[3]);
- }
- errString = "keyName valueName";
- break;
- case ValuesIdx: /* values */
- if (objc == 3) {
- return GetValueNames(interp, objv[2], NULL);
- } else if (objc == 4) {
- return GetValueNames(interp, objv[2], objv[3]);
+ if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
+ return TCL_ERROR;
}
- errString = "keyName ?pattern?";
- break;
+ RegCloseKey(key);
+ return TCL_OK;
+ } else if (objc == 5 || objc == 6) {
+ Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
+ return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
+ }
+ errString = "keyName ?valueName data ?type??";
+ break;
+ case TypeIdx: /* type */
+ if (objc == 4) {
+ return GetType(interp, objv[2], objv[3]);
+ }
+ errString = "keyName valueName";
+ break;
+ case ValuesIdx: /* values */
+ if (objc == 3) {
+ return GetValueNames(interp, objv[2], NULL);
+ } else if (objc == 4) {
+ return GetValueNames(interp, objv[2], objv[3]);
+ }
+ errString = "keyName ?pattern?";
+ break;
}
Tcl_WrongNumArgs(interp, 2, objv, errString);
return TCL_ERROR;
@@ -364,7 +442,6 @@ DeleteKey(
HKEY rootKey, subkey;
DWORD result;
int length;
- Tcl_Obj *resultPtr;
Tcl_DString buf;
/*
@@ -375,15 +452,15 @@ DeleteKey(
buffer = ckalloc((unsigned int) length + 1);
strcpy(buffer, keyName);
- if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName)
- != TCL_OK) {
+ if (ParseKeyName(interp, buffer, &hostName, &rootKey,
+ &keyName) != TCL_OK) {
ckfree(buffer);
return TCL_ERROR;
}
- resultPtr = Tcl_GetObjResult(interp);
if (*keyName == '\0') {
- Tcl_AppendToObj(resultPtr, "bad key: cannot delete root keys", -1);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad key: cannot delete root keys", -1));
ckfree(buffer);
return TCL_ERROR;
}
@@ -402,11 +479,11 @@ DeleteKey(
ckfree(buffer);
if (result == ERROR_FILE_NOT_FOUND) {
return TCL_OK;
- } else {
- Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
- AppendSystemError(interp, result);
- return TCL_ERROR;
}
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unable to delete key: ", -1));
+ AppendSystemError(interp, result);
+ return TCL_ERROR;
}
/*
@@ -418,7 +495,8 @@ DeleteKey(
Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
- Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("unable to delete key: ", -1));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
@@ -456,7 +534,6 @@ DeleteValue(
char *valueName;
int length;
DWORD result;
- Tcl_Obj *resultPtr;
Tcl_DString ds;
/*
@@ -468,13 +545,12 @@ DeleteValue(
return TCL_ERROR;
}
- resultPtr = Tcl_GetObjResult(interp);
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
Tcl_WinUtfToTChar(valueName, length, &ds);
result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
- Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"",
+ Tcl_AppendResult(interp, "unable to delete value \"",
Tcl_GetString(valueNameObj), "\" from key \"",
Tcl_GetString(keyNameObj), "\": ", NULL);
AppendSystemError(interp, result);
@@ -491,13 +567,13 @@ DeleteValue(
*
* GetKeyNames --
*
- * This function enumerates the subkeys of a given key. If the
- * optional pattern is supplied, then only keys that match the
- * pattern will be returned.
+ * This function enumerates the subkeys of a given key. If the optional
+ * pattern is supplied, then only keys that match the pattern will be
+ * returned.
*
* Results:
- * Returns the list of subkeys in the result object of the
- * interpreter, or an error message on failure.
+ * Returns the list of subkeys in the result object of the interpreter,
+ * or an error message on failure.
*
* Side effects:
* None.
@@ -513,9 +589,7 @@ GetKeyNames(
{
char *pattern; /* Pattern being matched against subkeys */
HKEY key; /* Handle to the key being examined */
- DWORD subKeyCount; /* Number of subkeys to list */
- DWORD maxSubKeyLen; /* Maximum string length of any subkey */
- char *buffer; /* Buffer to hold the subkey name */
+ TCHAR buffer[MAX_KEY_LENGTH*2]; /* Buffer to hold the subkey name */
DWORD bufSize; /* Size of the buffer */
DWORD index; /* Position of the current subkey */
char *name; /* Subkey name */
@@ -537,43 +611,24 @@ GetKeyNames(
return TCL_ERROR;
}
- /*
- * Determine how big a buffer is needed for enumerating subkeys, and
- * how many subkeys there are
- */
-
- result = (*regWinProcs->regQueryInfoKeyProc)
- (key, NULL, NULL, NULL, &subKeyCount, &maxSubKeyLen, NULL, NULL,
- NULL, NULL, NULL, NULL);
- if (result != ERROR_SUCCESS) {
- Tcl_SetObjResult(interp, Tcl_NewObj());
- Tcl_AppendResult(interp, "unable to query key \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
- AppendSystemError(interp, result);
- RegCloseKey(key);
- return TCL_ERROR;
- }
- if (regWinProcs->useWide) {
- buffer = ckalloc((maxSubKeyLen+1) * sizeof(WCHAR));
- } else {
- buffer = ckalloc(maxSubKeyLen+1);
- }
-
/* Enumerate the subkeys */
resultPtr = Tcl_NewObj();
- for (index = 0; index < subKeyCount; ++index) {
- bufSize = maxSubKeyLen+1;
+ for (index = 0;; ++index) {
+ bufSize = MAX_KEY_LENGTH;
result = (*regWinProcs->regEnumKeyExProc)
(key, index, buffer, &bufSize, NULL, NULL, NULL, NULL);
if (result != ERROR_SUCCESS) {
- Tcl_SetObjResult(interp, Tcl_NewObj());
- Tcl_AppendResult(interp,
- "unable to enumerate subkeys of \"",
- Tcl_GetString(keyNameObj),
- "\": ", NULL);
- AppendSystemError(interp, result);
- result = TCL_ERROR;
+ if (result == ERROR_NO_MORE_ITEMS) {
+ result = TCL_OK;
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewObj());
+ Tcl_AppendResult(interp,
+ "unable to enumerate subkeys of \"",
+ Tcl_GetString(keyNameObj), "\": ", NULL);
+ AppendSystemError(interp, result);
+ result = TCL_ERROR;
+ }
break;
}
if (regWinProcs->useWide) {
@@ -599,7 +654,6 @@ GetKeyNames(
Tcl_DecrRefCount(resultPtr); /* BUGFIX: Don't leak on failure. */
}
- ckfree(buffer);
RegCloseKey(key);
return result;
}
@@ -609,8 +663,8 @@ GetKeyNames(
*
* GetType --
*
- * This function gets the type of a given registry value and
- * places it in the interpreter result.
+ * This function gets the type of a given registry value and places it in
+ * the interpreter result.
*
* Results:
* Returns a normal Tcl result.
@@ -628,7 +682,6 @@ GetType(
Tcl_Obj *valueNameObj) /* Name of value to get. */
{
HKEY key;
- Tcl_Obj *resultPtr;
DWORD result;
DWORD type;
Tcl_DString ds;
@@ -649,8 +702,6 @@ GetType(
* Get the type of the value.
*/
- resultPtr = Tcl_GetObjResult(interp);
-
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds);
result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type,
@@ -659,7 +710,7 @@ GetType(
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
- Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"",
+ Tcl_AppendResult(interp, "unable to get type of value \"",
Tcl_GetString(valueNameObj), "\" from key \"",
Tcl_GetString(keyNameObj), "\": ", NULL);
AppendSystemError(interp, result);
@@ -667,14 +718,14 @@ GetType(
}
/*
- * Set the type into the result. Watch out for unknown types.
- * If we don't know about the type, just use the numeric value.
+ * Set the type into the result. Watch out for unknown types. If we don't
+ * know about the type, just use the numeric value.
*/
if (type > lastType) {
- Tcl_SetIntObj(resultPtr, (int) type);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type));
} else {
- Tcl_SetStringObj(resultPtr, typeNames[type], -1);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1));
}
return TCL_OK;
}
@@ -684,9 +735,8 @@ GetType(
*
* GetValue --
*
- * This function gets the contents of a registry value and places
- * a list containing the data and the type in the interpreter
- * result.
+ * This function gets the contents of a registry value and places a list
+ * containing the data and the type in the interpreter result.
*
* Results:
* Returns a normal Tcl result.
@@ -707,7 +757,6 @@ GetValue(
char *valueName;
CONST char *nativeValue;
DWORD result, length, type;
- Tcl_Obj *resultPtr;
Tcl_DString data, buf;
int nameLen;
@@ -715,16 +764,15 @@ GetValue(
* Attempt to open the key for reading.
*/
- if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
- != TCL_OK) {
+ if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
/*
- * Initialize a Dstring to maximum statically allocated size
- * we could get one more byte by avoiding Tcl_DStringSetLength()
- * and just setting length to TCL_DSTRING_STATIC_SIZE, but this
- * should be safer if the implementation of Dstrings changes.
+ * Initialize a Dstring to maximum statically allocated size we could get
+ * one more byte by avoiding Tcl_DStringSetLength() and just setting
+ * length to TCL_DSTRING_STATIC_SIZE, but this should be safer if the
+ * implementation of Dstrings changes.
*
* This allows short values to be read from the registy in one call.
* Longer values need a second call with an expanded DString.
@@ -734,8 +782,6 @@ GetValue(
Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
length = TCL_DSTRING_STATIC_SIZE / (regWinProcs->useWide ? 2 : 1) - 1;
- resultPtr = Tcl_GetObjResult(interp);
-
valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);
nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf);
@@ -743,11 +789,12 @@ GetValue(
(BYTE *) Tcl_DStringValue(&data), &length);
while (result == ERROR_MORE_DATA) {
/*
- * The Windows docs say that in this error case, we just need
- * to expand our buffer and request more data.
- * Required for HKEY_PERFORMANCE_DATA
+ * The Windows docs say that in this error case, we just need to
+ * expand our buffer and request more data. Required for
+ * HKEY_PERFORMANCE_DATA
*/
- length *= 2;
+
+ length = Tcl_DStringLength(&data) * (regWinProcs->useWide ? 1 : 2);
Tcl_DStringSetLength(&data, (int) length * (regWinProcs->useWide ? 2 : 1));
result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue,
NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
@@ -755,7 +802,7 @@ GetValue(
Tcl_DStringFree(&buf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
- Tcl_AppendStringsToObj(resultPtr, "unable to get value \"",
+ Tcl_AppendResult(interp, "unable to get value \"",
Tcl_GetString(valueNameObj), "\" from key \"",
Tcl_GetString(keyNameObj), "\": ", NULL);
AppendSystemError(interp, result);
@@ -764,26 +811,27 @@ GetValue(
}
/*
- * If the data is a 32-bit quantity, store it as an integer object. If it
- * is a multi-string, store it as a list of strings. For null-terminated
- * strings, append up the to first null. Otherwise, store it as a binary
+ * If the data is a 32-bit quantity, store it as an integer object. If it
+ * is a multi-string, store it as a list of strings. For null-terminated
+ * strings, append up the to first null. Otherwise, store it as a binary
* string.
*/
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
- Tcl_SetIntObj(resultPtr, (int) ConvertDWORD(type,
- *((DWORD*) Tcl_DStringValue(&data))));
+ Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type,
+ *((DWORD*) Tcl_DStringValue(&data)))));
} else if (type == REG_MULTI_SZ) {
char *p = Tcl_DStringValue(&data);
char *end = Tcl_DStringValue(&data) + length;
+ Tcl_Obj *resultPtr = Tcl_NewObj();
/*
* Multistrings are stored as an array of null-terminated strings,
- * terminated by two null characters. Also do a bounds check in
- * case we get bogus data.
+ * terminated by two null characters. Also do a bounds check in case
+ * we get bogus data.
*/
-
- while (p < end && ((regWinProcs->useWide)
+
+ while (p < end && ((regWinProcs->useWide)
? *((Tcl_UniChar *)p) : *p) != 0) {
Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
Tcl_ListObjAppendElement(interp, resultPtr,
@@ -798,17 +846,17 @@ GetValue(
}
Tcl_DStringFree(&buf);
}
+ Tcl_SetObjResult(interp, resultPtr);
} else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf);
- Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buf),
- Tcl_DStringLength(&buf));
- Tcl_DStringFree(&buf);
+ Tcl_DStringResult(interp, &buf);
} else {
/*
* Save binary data as a byte array.
*/
- Tcl_SetByteArrayObj(resultPtr, (BYTE *) Tcl_DStringValue(&data), (int) length);
+ Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
+ (BYTE *) Tcl_DStringValue(&data), (int) length));
}
Tcl_DStringFree(&data);
return result;
@@ -819,9 +867,9 @@ GetValue(
*
* GetValueNames --
*
- * This function enumerates the values of the a given key. If
- * the optional pattern is supplied, then only value names that
- * match the pattern will be returned.
+ * This function enumerates the values of the a given key. If the
+ * optional pattern is supplied, then only value names that match the
+ * pattern will be returned.
*
* Results:
* Returns the list of value names in the result object of the
@@ -841,7 +889,7 @@ GetValueNames(
{
HKEY key;
Tcl_Obj *resultPtr;
- DWORD index, size, maxSize, result;
+ DWORD index, size, result;
Tcl_DString buffer, ds;
char *pattern, *name;
@@ -854,29 +902,10 @@ GetValueNames(
return TCL_ERROR;
}
- resultPtr = Tcl_GetObjResult(interp);
-
- /*
- * Query the key to determine the appropriate buffer size to hold the
- * largest value name plus the terminating null.
- */
-
- result = (*regWinProcs->regQueryInfoKeyProc)(key, NULL, NULL, NULL, NULL,
- NULL, NULL, &index, &maxSize, NULL, NULL, NULL);
- if (result != ERROR_SUCCESS) {
- Tcl_AppendStringsToObj(resultPtr, "unable to query key \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
- AppendSystemError(interp, result);
- RegCloseKey(key);
- result = TCL_ERROR;
- goto done;
- }
- maxSize++;
-
-
+ resultPtr = Tcl_NewObj();
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer,
- (int) ((regWinProcs->useWide) ? maxSize*2 : maxSize));
+ (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH*2 : MAX_KEY_LENGTH));
index = 0;
result = TCL_OK;
@@ -888,11 +917,11 @@ GetValueNames(
/*
* Enumerate the values under the given subkey until we get an error,
- * indicating the end of the list. Note that we need to reset size
- * after each iteration because RegEnumValue smashes the old value.
+ * indicating the end of the list. Note that we need to reset size after
+ * each iteration because RegEnumValue smashes the old value.
*/
- size = maxSize;
+ size = MAX_KEY_LENGTH;
while ((*regWinProcs->regEnumValueProc)(key, index,
Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL)
== ERROR_SUCCESS) {
@@ -901,7 +930,8 @@ GetValueNames(
size *= 2;
}
- Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, &ds);
+ Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size,
+ &ds);
name = Tcl_DStringValue(&ds);
if (!pattern || Tcl_StringMatch(name, pattern)) {
result = Tcl_ListObjAppendElement(interp, resultPtr,
@@ -914,11 +944,10 @@ GetValueNames(
Tcl_DStringFree(&ds);
index++;
- size = maxSize;
+ size = MAX_KEY_LENGTH;
}
+ Tcl_SetObjResult(interp, resultPtr);
Tcl_DStringFree(&buffer);
-
- done:
RegCloseKey(key);
return result;
}
@@ -928,12 +957,11 @@ GetValueNames(
*
* OpenKey --
*
- * This function opens the specified key. This function is a
- * simple wrapper around ParseKeyName and OpenSubKey.
+ * This function opens the specified key. This function is a simple
+ * wrapper around ParseKeyName and OpenSubKey.
*
* Results:
- * Returns the opened key in the keyPtr argument and a Tcl
- * result code.
+ * Returns the opened key in the keyPtr argument and a Tcl result code.
*
* Side effects:
* None.
@@ -962,8 +990,8 @@ OpenKey(
if (result == TCL_OK) {
result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr);
if (result != ERROR_SUCCESS) {
- Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
- Tcl_AppendToObj(resultPtr, "unable to open key: ", -1);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("unable to open key: ", -1));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
@@ -980,12 +1008,12 @@ OpenKey(
*
* OpenSubKey --
*
- * This function opens a given subkey of a root key on the
- * specified host.
+ * This function opens a given subkey of a root key on the specified
+ * host.
*
* Results:
- * Returns the opened key in the keyPtr and a Windows error code
- * as the return value.
+ * Returns the opened key in the keyPtr and a Windows error code as the
+ * return value.
*
* Side effects:
* None.
@@ -1020,8 +1048,8 @@ OpenSubKey(
}
/*
- * Now open the specified key with the requested permissions. Note
- * that this key must be closed by the caller.
+ * Now open the specified key with the requested permissions. Note that
+ * this key must be closed by the caller.
*/
keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf);
@@ -1029,19 +1057,16 @@ OpenSubKey(
DWORD create;
result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL,
REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
+ } else if (rootKey == HKEY_PERFORMANCE_DATA) {
+ /*
+ * Here we fudge it for this special root key. See MSDN for more info
+ * on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it.
+ */
+ *keyPtr = HKEY_PERFORMANCE_DATA;
+ result = ERROR_SUCCESS;
} else {
- if (rootKey == HKEY_PERFORMANCE_DATA) {
- /*
- * Here we fudge it for this special root key.
- * See MSDN for more info on HKEY_PERFORMANCE_DATA and
- * the peculiarities surrounding it
- */
- *keyPtr = HKEY_PERFORMANCE_DATA;
- result = ERROR_SUCCESS;
- } else {
- result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0,
- mode, keyPtr);
- }
+ result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode,
+ keyPtr);
}
Tcl_DStringFree(&buf);
@@ -1060,15 +1085,12 @@ OpenSubKey(
*
* ParseKeyName --
*
- * This function parses a key name into the host, root, and subkey
- * parts.
+ * This function parses a key name into the host, root, and subkey parts.
*
* Results:
- * The pointers to the start of the host and subkey names are
- * returned in the hostNamePtr and keyNamePtr variables. The
- * specified root HKEY is returned in rootKeyPtr. Returns
- * a standard Tcl result.
- *
+ * The pointers to the start of the host and subkey names are returned in
+ * the hostNamePtr and keyNamePtr variables. The specified root HKEY is
+ * returned in rootKeyPtr. Returns a standard Tcl result.
*
* Side effects:
* Modifies the name string by inserting nulls.
@@ -1086,7 +1108,7 @@ ParseKeyName(
{
char *rootName;
int result, index;
- Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp);
+ Tcl_Obj *rootObj;
/*
* Split the key into host and root portions.
@@ -1107,7 +1129,7 @@ ParseKeyName(
rootName = name;
}
if (!rootName) {
- Tcl_AppendStringsToObj(resultPtr, "bad key \"", name,
+ Tcl_AppendResult(interp, "bad key \"", name,
"\": must start with a valid root", NULL);
return TCL_ERROR;
}
@@ -1144,9 +1166,9 @@ ParseKeyName(
*
* RecursiveDeleteKey --
*
- * This function recursively deletes all the keys below a starting
- * key. Although Windows 95 does this automatically, we still need
- * to do this for Windows NT.
+ * This function recursively deletes all the keys below a starting key.
+ * Although Windows 95 does this automatically, we still need to do this
+ * for Windows NT.
*
* Results:
* Returns a Windows error code.
@@ -1163,7 +1185,7 @@ RecursiveDeleteKey(
CONST char *keyName) /* Name of key to be deleted in external
* encoding, not UTF. */
{
- DWORD result, size, maxSize;
+ DWORD result, size;
Tcl_DString subkey;
HKEY hKey;
@@ -1180,23 +1202,17 @@ RecursiveDeleteKey(
if (result != ERROR_SUCCESS) {
return result;
}
- result = (*regWinProcs->regQueryInfoKeyProc)(hKey, NULL, NULL, NULL, NULL,
- &maxSize, NULL, NULL, NULL, NULL, NULL, NULL);
- maxSize++;
- if (result != ERROR_SUCCESS) {
- return result;
- }
Tcl_DStringInit(&subkey);
Tcl_DStringSetLength(&subkey,
- (int) ((regWinProcs->useWide) ? maxSize * 2 : maxSize));
+ (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH * 2 : MAX_KEY_LENGTH));
while (result == ERROR_SUCCESS) {
/*
* Always get index 0 because key deletion changes ordering.
*/
- size = maxSize;
+ size = MAX_KEY_LENGTH;
result=(*regWinProcs->regEnumKeyExProc)(hKey, 0,
Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL);
if (result == ERROR_NO_MORE_ITEMS) {
@@ -1216,9 +1232,9 @@ RecursiveDeleteKey(
*
* SetValue --
*
- * This function sets the contents of a registry value. If
- * the key or value does not exist, it will be created. If it
- * does exist, then the data and type will be replaced.
+ * This function sets the contents of a registry value. If the key or
+ * value does not exist, it will be created. If it does exist, then the
+ * data and type will be replaced.
*
* Results:
* Returns a normal Tcl result.
@@ -1237,11 +1253,11 @@ SetValue(
Tcl_Obj *dataObj, /* Data to be written. */
Tcl_Obj *typeObj) /* Type of data to be written. */
{
- DWORD type, result;
+ int type;
+ DWORD result;
HKEY key;
int length;
char *valueName;
- Tcl_Obj *resultPtr;
Tcl_DString nameBuf;
if (typeObj == NULL) {
@@ -1259,19 +1275,19 @@ SetValue(
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf);
- resultPtr = Tcl_GetObjResult(interp);
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
- DWORD value;
- if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) {
+ int value;
+
+ if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) {
RegCloseKey(key);
Tcl_DStringFree(&nameBuf);
return TCL_ERROR;
}
- value = ConvertDWORD(type, value);
- result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
- (BYTE*) &value, sizeof(DWORD));
+ value = ConvertDWORD((DWORD)type, (DWORD)value);
+ result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
+ (DWORD) type, (BYTE *) &value, sizeof(DWORD));
} else if (type == REG_MULTI_SZ) {
Tcl_DString data, buf;
int objc, i;
@@ -1284,9 +1300,9 @@ SetValue(
}
/*
- * Append the elements as null terminated strings. Note that
- * we must not assume the length of the string in case there are
- * embedded nulls, which aren't allowed in REG_MULTI_SZ values.
+ * Append the elements as null terminated strings. Note that we must
+ * not assume the length of the string in case there are embedded
+ * nulls, which aren't allowed in REG_MULTI_SZ values.
*/
Tcl_DStringInit(&data);
@@ -1294,8 +1310,8 @@ SetValue(
Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1);
/*
- * Add a null character to separate this value from the next.
- * We accomplish this by growing the string by one byte. Since the
+ * Add a null character to separate this value from the next. We
+ * accomplish this by growing the string by one byte. Since the
* DString always tacks on an extra null byte, the new byte will
* already be set to null.
*/
@@ -1305,16 +1321,16 @@ SetValue(
Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
&buf);
- result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
- (BYTE *) Tcl_DStringValue(&buf),
+ result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
+ (DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
(DWORD) Tcl_DStringLength(&buf));
Tcl_DStringFree(&data);
Tcl_DStringFree(&buf);
} else if (type == REG_SZ || type == REG_EXPAND_SZ) {
Tcl_DString buf;
- char *data = Tcl_GetStringFromObj(dataObj, &length);
+ CONST char *data = Tcl_GetStringFromObj(dataObj, &length);
- data = (char *) Tcl_WinUtfToTChar(data, length, &buf);
+ data = Tcl_WinUtfToTChar(data, length, &buf);
/*
* Include the null in the length, padding if needed for Unicode.
@@ -1325,8 +1341,8 @@ SetValue(
}
length = Tcl_DStringLength(&buf) + 1;
- result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
- (BYTE*)data, (DWORD) length);
+ result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
+ (DWORD) type, (BYTE *) data, (DWORD) length);
Tcl_DStringFree(&buf);
} else {
BYTE *data;
@@ -1335,14 +1351,17 @@ SetValue(
* Store binary data in the registry.
*/
- data = Tcl_GetByteArrayFromObj(dataObj, &length);
- result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
- data, (DWORD) length);
+ data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length);
+ result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
+ (DWORD) type, data, (DWORD) length);
}
+
Tcl_DStringFree(&nameBuf);
RegCloseKey(key);
+
if (result != ERROR_SUCCESS) {
- Tcl_AppendToObj(resultPtr, "unable to set value: ", -1);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("unable to set value: ", -1));
AppendSystemError(interp, result);
return TCL_ERROR;
}
@@ -1354,9 +1373,8 @@ SetValue(
*
* BroadcastValue --
*
- * This function broadcasts a WM_SETTINGCHANGE message to indicate
- * to other programs that we have changed the contents of a registry
- * value.
+ * This function broadcasts a WM_SETTINGCHANGE message to indicate to
+ * other programs that we have changed the contents of a registry value.
*
* Results:
* Returns a normal Tcl result.
@@ -1371,13 +1389,13 @@ static int
BroadcastValue(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj * CONST objv[]) /* Argument values. */
+ Tcl_Obj *CONST objv[]) /* Argument values. */
{
LRESULT result;
DWORD_PTR sendResult;
UINT timeout = 3000;
int len;
- char *str;
+ CONST char *str;
Tcl_Obj *objPtr;
if ((objc != 3) && (objc != 5)) {
@@ -1387,7 +1405,8 @@ BroadcastValue(
if (objc > 3) {
str = Tcl_GetStringFromObj(objv[3], &len);
- if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", (size_t) len)) {
+ if ((len < 2) || (*str != '-')
+ || strncmp(str, "-timeout", (size_t) len)) {
Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
return TCL_ERROR;
}
@@ -1404,6 +1423,7 @@ BroadcastValue(
/*
* Use the ignore the result.
*/
+
result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
(WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult);
@@ -1420,8 +1440,8 @@ BroadcastValue(
*
* AppendSystemError --
*
- * This routine formats a Windows system error message and places
- * it into the interpreter result.
+ * This routine formats a Windows system error message and places it into
+ * the interpreter result.
*
* Results:
* None.
@@ -1438,15 +1458,18 @@ 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;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+ if (Tcl_IsShared(resultPtr)) {
+ resultPtr = Tcl_DuplicateObj(resultPtr);
+ }
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;
@@ -1483,6 +1506,7 @@ AppendSystemError(
/*
* Trim the trailing CR/LF from the system message.
*/
+
if (msg[length-1] == '\n') {
msg[--length] = 0;
}
@@ -1492,8 +1516,9 @@ 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);
+ Tcl_SetObjResult(interp, resultPtr);
if (length != 0) {
Tcl_DStringFree(&ds);
@@ -1505,8 +1530,8 @@ AppendSystemError(
*
* ConvertDWORD --
*
- * This function determines whether a DWORD needs to be byte
- * swapped, and returns the appropriately swapped value.
+ * This function determines whether a DWORD needs to be byte swapped, and
+ * returns the appropriately swapped value.
*
* Results:
* Returns a converted DWORD.
@@ -1529,6 +1554,14 @@ ConvertDWORD(
* Check to see if the low bit is in the first byte.
*/
- localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
- return (type != localType) ? (DWORD)SWAPLONG(value) : value;
+ localType = (*((char*) &order) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
+ return (type != localType) ? (DWORD) SWAPLONG(value) : value;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
generated by cgit v0.12 at 2024-11-22 23:16:36 (GMT)