/* * 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. * * RCS: @(#) $Id: tclWinReg.c,v 1.8 1999/03/10 05:52:53 stanton Exp $ */ #include #include #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN /* * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the * Registry_Init declaration is in the source file itself, which is only * accessed when we are building a library. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLEXPORT /* * 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", "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", 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_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 int Registry_Init(Tcl_Interp *interp); /* *---------------------------------------------------------------------- * * Registry_Init -- * * This procedure initializes the registry command. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Registry_Init( Tcl_Interp *interp) { if (!Tcl_InitStubs(interp, "8.0", 0)) { return TCL_ERROR; } 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 || type < 0) { 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; } /* * 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 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. */ Tcl_DStringInit(&data); Tcl_DStringSetLength(&data, length = TCL_DSTRING_STATIC_SIZE - 1); resultPtr = Tcl_GetObjResult(interp); valueName = Tcl_GetStringFromObj(valueNameObj, NULL); result = RegQueryValueEx(key, valueName, NULL, &type, (LPBYTE) Tcl_DStringValue(&data), &length); if (result == ERROR_MORE_DATA) { 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; }