summaryrefslogtreecommitdiffstats
path: root/win/tclWinReg.c
diff options
context:
space:
mode:
authorrjohnson <rjohnson>1998-03-26 14:56:55 (GMT)
committerrjohnson <rjohnson>1998-03-26 14:56:55 (GMT)
commit72d823b9193f9ee2b0318563b49363cd08c11f24 (patch)
treec168cc164a71f320db9dcdfe7518ba7bd0d2c8d9 /win/tclWinReg.c
parent2b5738da524e944cda39e24c0a87b745a43bd8c3 (diff)
downloadtcl-72d823b9193f9ee2b0318563b49363cd08c11f24.zip
tcl-72d823b9193f9ee2b0318563b49363cd08c11f24.tar.gz
tcl-72d823b9193f9ee2b0318563b49363cd08c11f24.tar.bz2
Initial revision
Diffstat (limited to 'win/tclWinReg.c')
-rw-r--r--win/tclWinReg.c1212
1 files changed, 1212 insertions, 0 deletions
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
new file mode 100644
index 0000000..5e5d450
--- /dev/null
+++ b/win/tclWinReg.c
@@ -0,0 +1,1212 @@
+/*
+ * 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.
+ *
+ * Copyright (c) 1997 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWinReg.c 1.8 97/08/01 11:17:49
+ */
+
+#include <tcl.h>
+#include <stdlib.h>
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+
+/*
+ * VC++ has an alternate entry point called DllMain, so we need to rename
+ * our entry point.
+ */
+
+#ifndef STATIC_BUILD
+#if defined(_MSC_VER)
+# define EXPORT(a,b) __declspec(dllexport) a b
+# define DllEntryPoint DllMain
+#else
+# if defined(__BORLANDC__)
+# define EXPORT(a,b) a _export b
+# else
+# define EXPORT(a,b) a b
+# endif
+#endif
+#endif
+
+/*
+ * The following macros convert between different endian ints.
+ */
+
+#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
+#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.
+ */
+
+#define REG_CREATE 1
+
+/*
+ * The following tables contain the mapping from registry root names
+ * to the system predefined keys.
+ */
+
+static char *rootKeyNames[] = {
+ "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
+ "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", NULL
+};
+
+static HKEY rootKeys[] = {
+ HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
+ HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
+};
+
+/*
+ * 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 char *typeNames[] = {
+ "none", "sz", "expand_sz", "binary", "dword",
+ "dword_big_endian", "link", "multi_sz", "resource_list", NULL
+};
+
+static DWORD lastType = REG_RESOURCE_REQUIREMENTS_LIST;
+
+
+/*
+ * Declarations for functions defined in this file.
+ */
+
+static void AppendSystemError(Tcl_Interp *interp, DWORD error);
+static DWORD ConvertDWORD(DWORD type, DWORD value);
+static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);
+static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
+ Tcl_Obj *valueNameObj);
+static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
+ Tcl_Obj *patternObj);
+static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
+ Tcl_Obj *valueNameObj);
+static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
+ Tcl_Obj *valueNameObj);
+static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
+ Tcl_Obj *patternObj);
+static int OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
+ REGSAM mode, int flags, HKEY *keyPtr);
+static DWORD OpenSubKey(char *hostName, HKEY rootKey,
+ char *keyName, REGSAM mode, int flags,
+ HKEY *keyPtr);
+static int ParseKeyName(Tcl_Interp *interp, char *name,
+ char **hostNamePtr, HKEY *rootKeyPtr,
+ char **keyNamePtr);
+static DWORD RecursiveDeleteKey(HKEY hStartKey, LPTSTR pKeyName);
+static int RegistryObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]);
+static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
+ Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
+ Tcl_Obj *typeObj);
+
+EXTERN EXPORT(int,Registry_Init)(Tcl_Interp *interp);
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DllEntryPoint --
+ *
+ * This wrapper function is used by Windows to invoke the
+ * initialization code for the DLL. If we are compiling
+ * with Visual C++, this routine will be renamed to DllMain.
+ * routine.
+ *
+ * Results:
+ * Returns TRUE;
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef __WIN32__
+#ifndef STATIC_BUILD
+BOOL APIENTRY
+DllEntryPoint(
+ HINSTANCE hInst, /* Library instance handle. */
+ DWORD reason, /* Reason this function is being called. */
+ LPVOID reserved) /* Not used. */
+{
+ return TRUE;
+}
+#endif
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Registry_Init --
+ *
+ * This procedure initializes the registry command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+EXPORT(int,Registry_Init)(
+ Tcl_Interp *interp)
+{
+ Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);
+ return Tcl_PkgProvide(interp, "registry", "1.0");
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RegistryObjCmd --
+ *
+ * This function implements the Tcl "registry" command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+RegistryObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj * CONST objv[]) /* Argument values. */
+{
+ int index;
+ char *errString;
+
+ static char *subcommands[] = { "delete", "get", "keys", "set", "type",
+ "values", (char *) NULL };
+ enum SubCmdIdx { DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch (index) {
+ 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.
+ */
+
+ 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]);
+ }
+ errString = "keyName ?pattern?";
+ break;
+ }
+ Tcl_WrongNumArgs(interp, 2, objv, errString);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteKey --
+ *
+ * This function deletes a registry key.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DeleteKey(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *keyNameObj) /* Name of key to delete. */
+{
+ char *tail, *buffer, *hostName, *keyName;
+ HKEY rootKey, subkey;
+ DWORD result;
+ int length;
+ Tcl_Obj *resultPtr;
+
+ /*
+ * Find the parent of the key being deleted and open it.
+ */
+
+ keyName = Tcl_GetStringFromObj(keyNameObj, &length);
+ buffer = ckalloc(length + 1);
+ strcpy(buffer, keyName);
+
+ 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);
+ ckfree(buffer);
+ return TCL_ERROR;
+ }
+
+ tail = strrchr(keyName, '\\');
+ if (tail) {
+ *tail++ = '\0';
+ } else {
+ tail = keyName;
+ keyName = NULL;
+ }
+
+ result = OpenSubKey(hostName, rootKey, keyName,
+ KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey);
+ if (result != ERROR_SUCCESS) {
+ 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;
+ }
+ }
+
+ /*
+ * Now we recursively delete the key and everything below it.
+ */
+
+ result = RecursiveDeleteKey(subkey, tail);
+
+ if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
+ Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
+ AppendSystemError(interp, result);
+ result = TCL_ERROR;
+ } else {
+ result = TCL_OK;
+ }
+
+ RegCloseKey(subkey);
+ ckfree(buffer);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteValue --
+ *
+ * This function deletes a value from a registry key.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DeleteValue(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *keyNameObj, /* Name of key. */
+ Tcl_Obj *valueNameObj) /* Name of value to delete. */
+{
+ HKEY key;
+ char *valueName;
+ int length;
+ DWORD result;
+ Tcl_Obj *resultPtr;
+
+ /*
+ * Attempt to open the key for deletion.
+ */
+
+ if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ resultPtr = Tcl_GetObjResult(interp);
+ valueName = Tcl_GetStringFromObj(valueNameObj, &length);
+ result = RegDeleteValue(key, valueName);
+ if (result != ERROR_SUCCESS) {
+ Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"",
+ Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
+ Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
+ AppendSystemError(interp, result);
+ result = TCL_ERROR;
+ } else {
+ result = TCL_OK;
+ }
+ RegCloseKey(key);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Results:
+ * Returns the list of subkeys in the result object of the
+ * interpreter, or an error message on failure.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetKeyNames(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *keyNameObj, /* Key to enumerate. */
+ Tcl_Obj *patternObj) /* Optional match pattern. */
+{
+ HKEY key;
+ DWORD index;
+ char buffer[MAX_PATH+1], *pattern;
+ Tcl_Obj *resultPtr;
+ int result = TCL_OK;
+
+ /*
+ * Attempt to open the key for enumeration.
+ */
+
+ if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (patternObj) {
+ pattern = Tcl_GetStringFromObj(patternObj, NULL);
+ } else {
+ pattern = NULL;
+ }
+
+ /*
+ * Enumerate over the subkeys until we get an error, indicating the
+ * end of the list.
+ */
+
+ resultPtr = Tcl_GetObjResult(interp);
+ for (index = 0; RegEnumKey(key, index, buffer, MAX_PATH+1)
+ == ERROR_SUCCESS; index++) {
+ if (pattern && !Tcl_StringMatch(buffer, pattern)) {
+ continue;
+ }
+ result = Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(buffer, -1));
+ if (result != TCL_OK) {
+ break;
+ }
+ }
+
+ RegCloseKey(key);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetType --
+ *
+ * This function gets the type of a given registry value and
+ * places it in the interpreter result.
+ *
+ * Results:
+ * Returns a normal Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetType(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *keyNameObj, /* Name of key. */
+ Tcl_Obj *valueNameObj) /* Name of value to get. */
+{
+ HKEY key;
+ Tcl_Obj *resultPtr;
+ DWORD result;
+ DWORD type;
+
+ /*
+ * Attempt to open the key for reading.
+ */
+
+ if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the type of the value.
+ */
+
+ resultPtr = Tcl_GetObjResult(interp);
+
+ result = RegQueryValueEx(key, Tcl_GetStringFromObj(valueNameObj, NULL),
+ NULL, &type, NULL, NULL);
+ RegCloseKey(key);
+
+ if (result != ERROR_SUCCESS) {
+ Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"",
+ Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
+ Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
+ AppendSystemError(interp, result);
+ return TCL_ERROR;
+ }
+
+ /*
+ * 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, type);
+ } else {
+ Tcl_SetStringObj(resultPtr, typeNames[type], -1);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetValue --
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetValue(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *keyNameObj, /* Name of key. */
+ Tcl_Obj *valueNameObj) /* Name of value to get. */
+{
+ HKEY key;
+ char *valueName;
+ DWORD result, length, type;
+ Tcl_Obj *resultPtr;
+ Tcl_DString data;
+
+ /*
+ * Attempt to open the key for reading.
+ */
+
+ if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the value once to determine the length then again to store
+ * the data in the buffer.
+ */
+
+ Tcl_DStringInit(&data);
+ resultPtr = Tcl_GetObjResult(interp);
+
+ valueName = Tcl_GetStringFromObj(valueNameObj, (int*) &length);
+ result = RegQueryValueEx(key, valueName, NULL, &type, NULL, &length);
+ if (result == ERROR_SUCCESS) {
+ Tcl_DStringSetLength(&data, length);
+ result = RegQueryValueEx(key, valueName, NULL, &type,
+ (LPBYTE) Tcl_DStringValue(&data), &length);
+ }
+ RegCloseKey(key);
+ if (result != ERROR_SUCCESS) {
+ Tcl_AppendStringsToObj(resultPtr, "unable to get value \"",
+ Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
+ Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
+ AppendSystemError(interp, result);
+ Tcl_DStringFree(&data);
+ return TCL_ERROR;
+ }
+
+ /*
+ * 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, ConvertDWORD(type,
+ *((DWORD*) Tcl_DStringValue(&data))));
+ } else if (type == REG_MULTI_SZ) {
+ char *p = Tcl_DStringValue(&data);
+ char *lastChar = Tcl_DStringValue(&data) + Tcl_DStringLength(&data);
+
+ /*
+ * 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.
+ */
+
+ while (p < lastChar && *p != '\0') {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(p, -1));
+ while (*p++ != '\0') {}
+ }
+ } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
+ Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), -1);
+ } else {
+ Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), length);
+ }
+ Tcl_DStringFree(&data);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Results:
+ * Returns the list of value names in the result object of the
+ * interpreter, or an error message on failure.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetValueNames(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *keyNameObj, /* Key to enumerate. */
+ Tcl_Obj *patternObj) /* Optional match pattern. */
+{
+ HKEY key;
+ Tcl_Obj *resultPtr;
+ DWORD index, size, result;
+ Tcl_DString buffer;
+ char *pattern;
+
+ /*
+ * Attempt to open the key for enumeration.
+ */
+
+ if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
+ != TCL_OK) {
+ 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 = RegQueryInfoKey(key, NULL, NULL, NULL, NULL, NULL, NULL, &index,
+ &size, NULL, NULL, NULL);
+ if (result != ERROR_SUCCESS) {
+ Tcl_AppendStringsToObj(resultPtr, "unable to query key \"",
+ Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
+ AppendSystemError(interp, result);
+ RegCloseKey(key);
+ result = TCL_ERROR;
+ goto done;
+ }
+ size++;
+
+
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringSetLength(&buffer, size);
+ index = 0;
+ result = TCL_OK;
+
+ if (patternObj) {
+ pattern = Tcl_GetStringFromObj(patternObj, NULL);
+ } else {
+ pattern = NULL;
+ }
+
+ /*
+ * 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.
+ */
+
+ while (RegEnumValue(key, index, Tcl_DStringValue(&buffer), &size, NULL,
+ NULL, NULL, NULL) == ERROR_SUCCESS) {
+ if (!pattern || Tcl_StringMatch(Tcl_DStringValue(&buffer), pattern)) {
+ result = Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(Tcl_DStringValue(&buffer), size));
+ if (result != TCL_OK) {
+ break;
+ }
+ }
+ index++;
+ size = Tcl_DStringLength(&buffer);
+ }
+ Tcl_DStringFree(&buffer);
+
+ done:
+ RegCloseKey(key);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * OpenKey --
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+OpenKey(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *keyNameObj, /* Key to open. */
+ REGSAM mode, /* Access mode. */
+ int flags, /* 0 or REG_CREATE. */
+ HKEY *keyPtr) /* Returned HKEY. */
+{
+ char *keyName, *buffer, *hostName;
+ int length;
+ HKEY rootKey;
+ DWORD result;
+
+ keyName = Tcl_GetStringFromObj(keyNameObj, &length);
+ buffer = ckalloc(length + 1);
+ strcpy(buffer, keyName);
+
+ result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
+ 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);
+ AppendSystemError(interp, result);
+ result = TCL_ERROR;
+ } else {
+ result = TCL_OK;
+ }
+ }
+
+ ckfree(buffer);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * OpenSubKey --
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static DWORD
+OpenSubKey(
+ char *hostName, /* Host to access, or NULL for local. */
+ HKEY rootKey, /* Root registry key. */
+ char *keyName, /* Subkey name. */
+ REGSAM mode, /* Access mode. */
+ int flags, /* 0 or REG_CREATE. */
+ HKEY *keyPtr) /* Returned HKEY. */
+{
+ DWORD result;
+
+ /*
+ * Attempt to open the root key on a remote host if necessary.
+ */
+
+ if (hostName) {
+ result = RegConnectRegistry(hostName, rootKey, &rootKey);
+ if (result != ERROR_SUCCESS) {
+ return result;
+ }
+ }
+
+ /*
+ * Now open the specified key with the requested permissions. Note
+ * that this key must be closed by the caller.
+ */
+
+ if (flags & REG_CREATE) {
+ DWORD create;
+ result = RegCreateKeyEx(rootKey, keyName, 0, "",
+ REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
+ } else {
+ result = RegOpenKeyEx(rootKey, keyName, 0, mode, keyPtr);
+ }
+
+ /*
+ * Be sure to close the root key since we are done with it now.
+ */
+
+ if (hostName) {
+ RegCloseKey(rootKey);
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseKeyName --
+ *
+ * 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.
+ *
+ *
+ * Side effects:
+ * Modifies the name string by inserting nulls.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseKeyName(
+ Tcl_Interp *interp, /* Current interpreter. */
+ char *name,
+ char **hostNamePtr,
+ HKEY *rootKeyPtr,
+ char **keyNamePtr)
+{
+ char *rootName;
+ int result, index;
+ Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp);
+
+ /*
+ * Split the key into host and root portions.
+ */
+
+ *hostNamePtr = *keyNamePtr = rootName = NULL;
+ if (name[0] == '\\') {
+ if (name[1] == '\\') {
+ *hostNamePtr = name;
+ for (rootName = name+2; *rootName != '\0'; rootName++) {
+ if (*rootName == '\\') {
+ *rootName++ = '\0';
+ break;
+ }
+ }
+ }
+ } else {
+ rootName = name;
+ }
+ if (!rootName) {
+ Tcl_AppendStringsToObj(resultPtr, "bad key \"", name,
+ "\": must start with a valid root", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Split the root into root and subkey portions.
+ */
+
+ for (*keyNamePtr = rootName; **keyNamePtr != '\0'; (*keyNamePtr)++) {
+ if (**keyNamePtr == '\\') {
+ **keyNamePtr = '\0';
+ (*keyNamePtr)++;
+ break;
+ }
+ }
+
+ /*
+ * Look for a matching root name.
+ */
+
+ rootObj = Tcl_NewStringObj(rootName, -1);
+ result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name",
+ TCL_EXACT, &index);
+ Tcl_DecrRefCount(rootObj);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ *rootKeyPtr = rootKeys[index];
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Results:
+ * Returns a Windows error code.
+ *
+ * Side effects:
+ * Deletes all of the keys and values below the given key.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static DWORD
+RecursiveDeleteKey(
+ HKEY startKey, /* Parent of key to be deleted. */
+ char *keyName) /* Name of key to be deleted. */
+{
+ DWORD result, subKeyLength;
+ Tcl_DString subkey;
+ HKEY hKey;
+
+ /*
+ * Do not allow NULL or empty key name.
+ */
+
+ if (!keyName || lstrlen(keyName) == '\0') {
+ return ERROR_BADKEY;
+ }
+
+ result = RegOpenKeyEx(startKey, keyName, 0,
+ KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey);
+ if (result != ERROR_SUCCESS) {
+ return result;
+ }
+ result = RegQueryInfoKey(hKey, NULL, NULL, NULL, NULL, &subKeyLength,
+ NULL, NULL, NULL, NULL, NULL, NULL);
+ subKeyLength++;
+ if (result != ERROR_SUCCESS) {
+ return result;
+ }
+
+ Tcl_DStringInit(&subkey);
+ Tcl_DStringSetLength(&subkey, subKeyLength);
+
+ while (result == ERROR_SUCCESS) {
+ /*
+ * Always get index 0 because key deletion changes ordering.
+ */
+
+ subKeyLength = Tcl_DStringLength(&subkey);
+ result=RegEnumKeyEx(hKey, 0, Tcl_DStringValue(&subkey), &subKeyLength,
+ NULL, NULL, NULL, NULL);
+ if (result == ERROR_NO_MORE_ITEMS) {
+ result = RegDeleteKey(startKey, keyName);
+ break;
+ } else if (result == ERROR_SUCCESS) {
+ result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey));
+ }
+ }
+ Tcl_DStringFree(&subkey);
+ RegCloseKey(hKey);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Results:
+ * Returns a normal Tcl result.
+ *
+ * Side effects:
+ * May create new keys or values.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetValue(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *keyNameObj, /* Name of key. */
+ Tcl_Obj *valueNameObj, /* Name of value to set. */
+ Tcl_Obj *dataObj, /* Data to be written. */
+ Tcl_Obj *typeObj) /* Type of data to be written. */
+{
+ DWORD type, result;
+ HKEY key;
+ int length;
+ char *valueName;
+ Tcl_Obj *resultPtr;
+
+ if (typeObj == NULL) {
+ type = REG_SZ;
+ } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type",
+ 0, (int *) &type) != TCL_OK) {
+ if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_ResetResult(interp);
+ }
+ if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ valueName = Tcl_GetStringFromObj(valueNameObj, &length);
+ resultPtr = Tcl_GetObjResult(interp);
+
+ if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
+ DWORD value;
+ if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) {
+ RegCloseKey(key);
+ return TCL_ERROR;
+ }
+
+ value = ConvertDWORD(type, value);
+ result = RegSetValueEx(key, valueName, 0, type, (BYTE*) &value,
+ sizeof(DWORD));
+ } else if (type == REG_MULTI_SZ) {
+ Tcl_DString data;
+ int objc, i;
+ Tcl_Obj **objv;
+ char *element;
+
+ if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
+ RegCloseKey(key);
+ return TCL_ERROR;
+ }
+
+ /*
+ * 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);
+ for (i = 0; i < objc; i++) {
+ element = Tcl_GetStringFromObj(objv[i], NULL);
+ Tcl_DStringAppend(&data, element, -1);
+ Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
+ }
+ result = RegSetValueEx(key, valueName, 0, type,
+ (LPBYTE) Tcl_DStringValue(&data),
+ (DWORD) (Tcl_DStringLength(&data)+1));
+ Tcl_DStringFree(&data);
+ } else {
+ char *data = Tcl_GetStringFromObj(dataObj, &length);
+
+ /*
+ * Include the null in the length if we are storing a null terminated
+ * string. Note that we also need to call strlen to find the first
+ * null so we don't pass bad data to the registry.
+ */
+
+ if (type == REG_SZ || type == REG_EXPAND_SZ) {
+ length = strlen(data) + 1;
+ }
+
+ result = RegSetValueEx(key, valueName, 0, type, (LPBYTE)data, length);
+ }
+ RegCloseKey(key);
+ if (result != ERROR_SUCCESS) {
+ Tcl_AppendToObj(resultPtr, "unable to set value: ", -1);
+ AppendSystemError(interp, result);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AppendSystemError --
+ *
+ * This routine formats a Windows system error message and places
+ * it into the interpreter result.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AppendSystemError(
+ Tcl_Interp *interp, /* Current interpreter. */
+ DWORD error) /* Result code from error. */
+{
+ int length;
+ char *msgbuf, id[10];
+ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+
+ sprintf(id, "%d", error);
+ length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
+ | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR)&msgbuf,
+ 0, NULL);
+ if (length == 0) {
+ if (error == ERROR_CALL_NOT_IMPLEMENTED) {
+ msgbuf = "function not supported under Win32s";
+ } else {
+ msgbuf = id;
+ }
+ } else {
+ /*
+ * Trim the trailing CR/LF from the system message.
+ */
+ if (msgbuf[length-1] == '\n') {
+ msgbuf[--length] = 0;
+ }
+ if (msgbuf[length-1] == '\r') {
+ msgbuf[--length] = 0;
+ }
+ }
+ Tcl_SetErrorCode(interp, "WINDOWS", id, msgbuf, (char *) NULL);
+ Tcl_AppendToObj(resultPtr, msgbuf, -1);
+
+ if (length != 0) {
+ LocalFree(msgbuf);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConvertDWORD --
+ *
+ * This function determines whether a DWORD needs to be byte
+ * swapped, and returns the appropriately swapped value.
+ *
+ * Results:
+ * Returns a converted DWORD.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static DWORD
+ConvertDWORD(
+ DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */
+ DWORD value) /* The value to be converted. */
+{
+ DWORD order = 1;
+ DWORD localType;
+
+ /*
+ * 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) ? SWAPLONG(value) : value;
+}