/* * 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. * 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. */ #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") #endif #include /* * Ensure that we can say which registry is being accessed. */ #ifndef KEY_WOW64_64KEY # define KEY_WOW64_64KEY (0x0100) #endif #ifndef KEY_WOW64_32KEY # define KEY_WOW64_32KEY (0x0200) #endif /* * 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. */ #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 const char *const rootKeyNames[] = { "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT", "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL }; static const HKEY rootKeys[] = { HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, 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. */ static const char *const 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 int BroadcastValue(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static DWORD ConvertDWORD(DWORD type, DWORD value); static void DeleteCmd(void *clientData); static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, REGSAM mode); static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, REGSAM mode); static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *patternObj, REGSAM mode); static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, REGSAM mode); static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, REGSAM mode); static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *patternObj, REGSAM mode); 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, const WCHAR * pKeyName, REGSAM mode); static int RegistryObjCmd(void *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, REGSAM mode); #if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 # define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) # define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) # else # define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString # define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString # endif #define Tcl_Size int #define TCL_INDEX_NONE -1 #endif #ifdef __cplusplus extern "C" { #endif DLLEXPORT int Registry_Init(Tcl_Interp *interp); DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); #if TCL_MAJOR_VERSION < 9 /* With those additional entries, "load registry13.dll" works without 3th argument */ DLLEXPORT int Tclregistry_Init(Tcl_Interp *interp); DLLEXPORT int Tclregistry_Unload(Tcl_Interp *interp, int flags); #endif #ifdef __cplusplus } #endif /* *---------------------------------------------------------------------- * * Registry_Init -- * * This function initializes the registry command. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Registry_Init( Tcl_Interp *interp) { Tcl_Command cmd; if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); return Tcl_PkgProvideEx(interp, "registry", "1.3.7", NULL); } #if TCL_MAJOR_VERSION < 9 int Tclregistry_Init( Tcl_Interp *interp) { return Registry_Init(interp); } #endif /* *---------------------------------------------------------------------- * * 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]; (void)flags; /* * Unregister the registry package. There is no Tcl_PkgForget() */ objv[0] = Tcl_NewStringObj("package", TCL_INDEX_NONE); objv[1] = Tcl_NewStringObj("forget", TCL_INDEX_NONE); objv[2] = Tcl_NewStringObj("registry", TCL_INDEX_NONE); 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; } #if TCL_MAJOR_VERSION < 9 int Tclregistry_Unload( Tcl_Interp *interp, int flags) { return Registry_Unload(interp, flags); } #endif /* *---------------------------------------------------------------------- * * 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( void *clientData) { Tcl_Interp *interp = (Tcl_Interp *)clientData; Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL); } /* *---------------------------------------------------------------------- * * RegistryObjCmd -- * * This function implements the Tcl "registry" command. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int RegistryObjCmd( void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { int n = 1; int index, argc; REGSAM mode = 0; const char *errString = NULL; static const char *const subcommands[] = { "broadcast", "delete", "get", "keys", "set", "type", "values", NULL }; enum SubCmdIdx { BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx }; static const char *const modes[] = { "-32bit", "-64bit", NULL }; (void)dummy; if (objc < 2) { wrongArgs: Tcl_WrongNumArgs(interp, 1, objv, "?-32bit|-64bit? option ?arg ...?"); return TCL_ERROR; } if (Tcl_GetString(objv[n])[0] == '-') { if (Tcl_GetIndexFromObj(interp, objv[n++], modes, "mode", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case 0: /* -32bit */ mode |= KEY_WOW64_32KEY; break; case 1: /* -64bit */ mode |= KEY_WOW64_64KEY; break; } if (objc < 3) { goto wrongArgs; } } if (Tcl_GetIndexFromObj(interp, objv[n++], subcommands, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } argc = (objc - n); switch (index) { case BroadcastIdx: /* broadcast */ if (argc == 1 || argc == 3) { int res = BroadcastValue(interp, argc, objv + n); if (res != TCL_BREAK) { return res; } } errString = "keyName ?-timeout milliseconds?"; break; case DeleteIdx: /* delete */ if (argc == 1) { return DeleteKey(interp, objv[n], mode); } else if (argc == 2) { return DeleteValue(interp, objv[n], objv[n+1], mode); } errString = "keyName ?valueName?"; break; case GetIdx: /* get */ if (argc == 2) { return GetValue(interp, objv[n], objv[n+1], mode); } errString = "keyName valueName"; break; case KeysIdx: /* keys */ if (argc == 1) { return GetKeyNames(interp, objv[n], NULL, mode); } else if (argc == 2) { return GetKeyNames(interp, objv[n], objv[n+1], mode); } errString = "keyName ?pattern?"; break; case SetIdx: /* set */ if (argc == 1) { HKEY key; /* * Create the key and then close it immediately. */ mode |= KEY_ALL_ACCESS; if (OpenKey(interp, objv[n], mode, 1, &key) != TCL_OK) { return TCL_ERROR; } RegCloseKey(key); return TCL_OK; } else if (argc == 3) { return SetValue(interp, objv[n], objv[n+1], objv[n+2], NULL, mode); } else if (argc == 4) { return SetValue(interp, objv[n], objv[n+1], objv[n+2], objv[n+3], mode); } errString = "keyName ?valueName data ?type??"; break; case TypeIdx: /* type */ if (argc == 2) { return GetType(interp, objv[n], objv[n+1], mode); } errString = "keyName valueName"; break; case ValuesIdx: /* values */ if (argc == 1) { return GetValueNames(interp, objv[n], NULL, mode); } else if (argc == 2) { return GetValueNames(interp, objv[n], objv[n+1], mode); } errString = "keyName ?pattern?"; break; } Tcl_WrongNumArgs(interp, (mode ? 3 : 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. */ REGSAM mode) /* Mode flags to pass. */ { char *tail, *buffer, *hostName, *keyName; const WCHAR *nativeTail; HKEY rootKey, subkey; DWORD result; Tcl_DString buf; REGSAM saveMode = mode; Tcl_Size len; /* * Find the parent of the key being deleted and open it. */ keyName = Tcl_GetStringFromObj(keyNameObj, &len); buffer = (char *)Tcl_Alloc(len + 1); strcpy(buffer, keyName); if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName) != TCL_OK) { Tcl_Free(buffer); return TCL_ERROR; } if (*keyName == '\0') { Tcl_SetObjResult(interp, Tcl_NewStringObj("bad key: cannot delete root keys", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL); Tcl_Free(buffer); return TCL_ERROR; } tail = strrchr(keyName, '\\'); if (tail) { *tail++ = '\0'; } else { tail = keyName; keyName = NULL; } mode |= KEY_ENUMERATE_SUB_KEYS | DELETE; result = OpenSubKey(hostName, rootKey, keyName, mode, 0, &subkey); if (result != ERROR_SUCCESS) { Tcl_Free(buffer); if (result == ERROR_FILE_NOT_FOUND) { return TCL_OK; } Tcl_SetObjResult(interp, Tcl_NewStringObj("unable to delete key: ", TCL_INDEX_NONE)); AppendSystemError(interp, result); return TCL_ERROR; } /* * Now we recursively delete the key and everything below it. */ Tcl_DStringInit(&buf); nativeTail = Tcl_UtfToWCharDString(tail, TCL_INDEX_NONE, &buf); result = RecursiveDeleteKey(subkey, nativeTail, saveMode); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { Tcl_SetObjResult(interp, Tcl_NewStringObj("unable to delete key: ", TCL_INDEX_NONE)); AppendSystemError(interp, result); result = TCL_ERROR; } else { result = TCL_OK; } RegCloseKey(subkey); Tcl_Free(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. */ REGSAM mode) /* Mode flags to pass. */ { HKEY key; char *valueName; DWORD result; Tcl_DString ds; Tcl_Size len; /* * Attempt to open the key for deletion. */ mode |= KEY_SET_VALUE; if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } valueName = Tcl_GetStringFromObj(valueNameObj, &len); Tcl_DStringInit(&ds); Tcl_UtfToWCharDString(valueName, len, &ds); result = RegDeleteValueW(key, (const WCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to delete value \"%s\" from key \"%s\": ", Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); 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. */ REGSAM mode) /* Mode flags to pass. */ { const char *pattern; /* Pattern being matched against subkeys */ HKEY key; /* Handle to the key being examined */ WCHAR buffer[MAX_KEY_LENGTH]; /* Buffer to hold the subkey name */ DWORD bufSize; /* Size of the buffer */ DWORD index; /* Position of the current subkey */ char *name; /* Subkey name */ Tcl_Obj *resultPtr; /* List of subkeys being accumulated */ int result = TCL_OK; /* Return value from this command */ Tcl_DString ds; /* Buffer to translate subkey name to UTF-8 */ if (patternObj) { pattern = Tcl_GetString(patternObj); } else { pattern = NULL; } /* * Attempt to open the key for enumeration. */ mode |= KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS; if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } /* * Enumerate the subkeys. */ resultPtr = Tcl_NewObj(); for (index = 0;; ++index) { bufSize = MAX_KEY_LENGTH; result = RegEnumKeyExW(key, index, buffer, &bufSize, NULL, NULL, NULL, NULL); if (result != ERROR_SUCCESS) { if (result == ERROR_NO_MORE_ITEMS) { result = TCL_OK; } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to enumerate subkeys of \"%s\": ", Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } break; } Tcl_DStringInit(&ds); name = Tcl_WCharToUtfDString(buffer, bufSize, &ds); if (pattern && !Tcl_StringMatch(name, pattern)) { Tcl_DStringFree(&ds); continue; } result = Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); Tcl_DStringFree(&ds); if (result != TCL_OK) { break; } } if (result == TCL_OK) { Tcl_SetObjResult(interp, resultPtr); } else { Tcl_DecrRefCount(resultPtr); /* BUGFIX: Don't leak on failure. */ } 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. */ REGSAM mode) /* Mode flags to pass. */ { HKEY key; DWORD result, type; Tcl_DString ds; const char *valueName; const WCHAR *nativeValue; Tcl_Size len; /* * Attempt to open the key for reading. */ mode |= KEY_QUERY_VALUE; if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } /* * Get the type of the value. */ valueName = Tcl_GetStringFromObj(valueNameObj, &len); Tcl_DStringInit(&ds); nativeValue = Tcl_UtfToWCharDString(valueName, len, &ds); result = RegQueryValueExW(key, nativeValue, NULL, &type, NULL, NULL); Tcl_DStringFree(&ds); RegCloseKey(key); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to get type of value \"%s\" from key \"%s\": ", Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); 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_SetObjResult(interp, Tcl_NewIntObj((int) type)); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], TCL_INDEX_NONE)); } 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. */ REGSAM mode) /* Mode flags to pass. */ { HKEY key; const char *valueName; const WCHAR *nativeValue; DWORD result, length, type; Tcl_DString data, buf; Tcl_Size len; /* * Attempt to open the key for reading. */ mode |= KEY_QUERY_VALUE; if (OpenKey(interp, keyNameObj, mode, 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. * * This allows short values to be read from the registry in one call. * Longer values need a second call with an expanded DString. */ Tcl_DStringInit(&data); Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1); length = TCL_DSTRING_STATIC_SIZE/sizeof(WCHAR) - 1; valueName = Tcl_GetStringFromObj(valueNameObj, &len); Tcl_DStringInit(&buf); nativeValue = Tcl_UtfToWCharDString(valueName, len, &buf); result = RegQueryValueExW(key, nativeValue, NULL, &type, (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 */ length = Tcl_DStringLength(&data) * (2 / sizeof(WCHAR)); Tcl_DStringSetLength(&data, length * sizeof(WCHAR)); result = RegQueryValueExW(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); } Tcl_DStringFree(&buf); RegCloseKey(key); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to get value \"%s\" from key \"%s\": ", Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); 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_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. */ while ((p < end) && *((WCHAR *) p) != 0) { WCHAR *wp = (WCHAR *) p; Tcl_DStringInit(&buf); Tcl_WCharToUtfDString(wp, wcslen(wp), &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); while (*wp++ != 0) {/* empty body */} p = (char *) wp; Tcl_DStringFree(&buf); } Tcl_SetObjResult(interp, resultPtr); } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { WCHAR *wp = (WCHAR *) Tcl_DStringValue(&data); Tcl_DStringInit(&buf); Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&data), wcslen(wp), &buf); Tcl_DStringResult(interp, &buf); } else { /* * Save binary data as a byte array. */ Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( (BYTE *) Tcl_DStringValue(&data), length)); } Tcl_DStringFree(&data); return result; } /* *---------------------------------------------------------------------- * * GetValueNames -- * * This function enumerates the values of the 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. */ REGSAM mode) /* Mode flags to pass. */ { HKEY key; Tcl_Obj *resultPtr; DWORD index, size, result; Tcl_DString buffer, ds; const char *pattern, *name; /* * Attempt to open the key for enumeration. */ mode |= KEY_QUERY_VALUE; if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } resultPtr = Tcl_NewObj(); Tcl_DStringInit(&buffer); Tcl_DStringSetLength(&buffer, MAX_KEY_LENGTH * sizeof(WCHAR)); index = 0; result = TCL_OK; if (patternObj) { pattern = Tcl_GetString(patternObj); } 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. */ size = MAX_KEY_LENGTH; while (RegEnumValueW(key,index, (WCHAR *)Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { Tcl_DStringInit(&ds); Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&buffer), size, &ds); name = Tcl_DStringValue(&ds); if (!pattern || Tcl_StringMatch(name, pattern)) { result = Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); if (result != TCL_OK) { Tcl_DStringFree(&ds); break; } } Tcl_DStringFree(&ds); index++; size = MAX_KEY_LENGTH; } Tcl_SetObjResult(interp, resultPtr); Tcl_DStringFree(&buffer); 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; HKEY rootKey; DWORD result; Tcl_Size len; keyName = Tcl_GetStringFromObj(keyNameObj, &len); buffer = (char *)Tcl_Alloc(len + 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_SetObjResult(interp, Tcl_NewStringObj("unable to open key: ", TCL_INDEX_NONE)); AppendSystemError(interp, result); result = TCL_ERROR; } else { result = TCL_OK; } } Tcl_Free(buffer); return result; } /* *---------------------------------------------------------------------- * * OpenSubKey -- * * Opens a given subkey of the given 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; Tcl_DString buf; /* * Attempt to open the root key on a remote host if necessary. */ if (hostName) { Tcl_DStringInit(&buf); hostName = (char *) Tcl_UtfToWCharDString(hostName, TCL_INDEX_NONE, &buf); result = RegConnectRegistryW((WCHAR *)hostName, rootKey, &rootKey); Tcl_DStringFree(&buf); 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 (keyName) { Tcl_DStringInit(&buf); keyName = (char *) Tcl_UtfToWCharDString(keyName, TCL_INDEX_NONE, &buf); } if (flags & REG_CREATE) { DWORD create; result = RegCreateKeyExW(rootKey, (WCHAR *)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 { result = RegOpenKeyExW(rootKey, (WCHAR *)keyName, 0, mode, keyPtr); } if (keyName) { Tcl_DStringFree(&buf); } /* * Be sure to close the root key since we are done with it now. */ if (hostName) { RegCloseKey(rootKey); } return result; } /* *---------------------------------------------------------------------- * * ParseKeyName -- * * 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; /* * 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_SetObjResult(interp, Tcl_ObjPrintf( "bad key \"%s\": must start with a valid root", name)); Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", 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, TCL_INDEX_NONE); 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. */ const WCHAR *keyName, /* Name of key to be deleted in external * encoding, not UTF. */ REGSAM mode) /* Mode flags to pass. */ { DWORD result, size; Tcl_DString subkey; HKEY hKey; REGSAM saveMode = mode; static int checkExProc = 0; static LONG (* regDeleteKeyExProc) (HKEY, LPCWSTR, REGSAM, DWORD) = (LONG (*) (HKEY, LPCWSTR, REGSAM, DWORD)) NULL; /* * Do not allow NULL or empty key name. */ if (!keyName || *keyName == '\0') { return ERROR_BADKEY; } mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE; result = RegOpenKeyExW(startKey, keyName, 0, mode, &hKey); if (result != ERROR_SUCCESS) { return result; } Tcl_DStringInit(&subkey); Tcl_DStringSetLength(&subkey, MAX_KEY_LENGTH * sizeof(WCHAR)); mode = saveMode; while (result == ERROR_SUCCESS) { /* * Always get index 0 because key deletion changes ordering. */ size = MAX_KEY_LENGTH; result = RegEnumKeyExW(hKey, 0, (WCHAR *)Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); if (result == ERROR_NO_MORE_ITEMS) { /* * RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we * can't compile with it in. We need to check for it at runtime * and use it if we find it. */ if (mode && !checkExProc) { HMODULE handle; checkExProc = 1; handle = GetModuleHandleW(L"ADVAPI32"); regDeleteKeyExProc = (LONG (*) (HKEY, LPCWSTR, REGSAM, DWORD)) (void *)GetProcAddress(handle, "RegDeleteKeyExW"); } if (mode && regDeleteKeyExProc) { result = regDeleteKeyExProc(startKey, keyName, mode, 0); } else { result = RegDeleteKeyW(startKey, keyName); } break; } else if (result == ERROR_SUCCESS) { result = RecursiveDeleteKey(hKey, (const WCHAR *) Tcl_DStringValue(&subkey), mode); } } 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. */ REGSAM mode) /* Mode flags to pass. */ { int type; DWORD result; HKEY key; const char *valueName; Tcl_DString nameBuf; Tcl_Size len; 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); } mode |= KEY_ALL_ACCESS; if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) { return TCL_ERROR; } valueName = Tcl_GetStringFromObj(valueNameObj, &len); Tcl_DStringInit(&nameBuf); valueName = (char *) Tcl_UtfToWCharDString(valueName, len, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { int value; if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) { RegCloseKey(key); Tcl_DStringFree(&nameBuf); return TCL_ERROR; } value = ConvertDWORD((DWORD) type, (DWORD) value); result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; Tcl_Size objc, i; Tcl_Obj **objv; if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) { RegCloseKey(key); Tcl_DStringFree(&nameBuf); 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++) { const char *bytes = Tcl_GetStringFromObj(objv[i], &len); Tcl_DStringAppend(&data, bytes, len); /* * Add a null character to separate this value from the next. */ Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */ } Tcl_DStringInit(&buf); Tcl_UtfToWCharDString(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, &buf); result = RegSetValueExW(key, (WCHAR *) 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; const char *data = Tcl_GetStringFromObj(dataObj, &len); Tcl_DStringInit(&buf); data = (char *) Tcl_UtfToWCharDString(data, len, &buf); /* * Include the null in the length, padding if needed for WCHAR. */ Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1); Tcl_DStringFree(&buf); } else { BYTE *data; Tcl_Size bytelength; /* * Store binary data in the registry. */ data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength); result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, data, (DWORD) bytelength); } Tcl_DStringFree(&nameBuf); RegCloseKey(key); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_NewStringObj("unable to set value: ", TCL_INDEX_NONE)); AppendSystemError(interp, result); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * BroadcastValue -- * * 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. * * Side effects: * Will cause other programs to reload their system settings. * *---------------------------------------------------------------------- */ static int BroadcastValue( Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { LRESULT result; DWORD_PTR sendResult; int timeout = 3000; Tcl_Size len; const char *str; Tcl_Obj *objPtr; WCHAR *wstr; Tcl_DString ds; if (objc == 3) { str = Tcl_GetStringFromObj(objv[1], &len); if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) { return TCL_BREAK; } if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) { return TCL_ERROR; } } str = Tcl_GetStringFromObj(objv[0], &len); Tcl_DStringInit(&ds); wstr = Tcl_UtfToWCharDString(str, len, &ds); if (Tcl_DStringLength(&ds) == 0) { wstr = NULL; } /* * Use the ignore the result. */ result = SendMessageTimeoutW(HWND_BROADCAST, WM_SETTINGCHANGE, (WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult); Tcl_DStringFree(&ds); objPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result)); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) sendResult)); Tcl_SetObjResult(interp, objPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * AppendSystemError -- * * 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; WCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; const 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 *) tMsgPtrPtr, 0, NULL); if (length == 0) { snprintf(msgBuf, sizeof(msgBuf), "unknown error: %ld", error); msg = msgBuf; } else { char *msgPtr; Tcl_DStringInit(&ds); Tcl_WCharToUtfDString(tMsgPtr, wcslen(tMsgPtr), &ds); LocalFree(tMsgPtr); msgPtr = Tcl_DStringValue(&ds); length = Tcl_DStringLength(&ds); /* * Trim the trailing CR/LF from the system message. */ if (msgPtr[length-1] == '\n') { --length; } if (msgPtr[length-1] == '\r') { --length; } msgPtr[length] = 0; msg = msgPtr; } snprintf(id, sizeof(id), "%ld", error); Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL); Tcl_AppendToObj(resultPtr, msg, length); Tcl_SetObjResult(interp, resultPtr); if (length != 0) { Tcl_DStringFree(&ds); } } /* *---------------------------------------------------------------------- * * ConvertDWORD -- * * 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. */ { const DWORD order = 1; DWORD localType; /* * Check to see if the low bit is in the first byte. */ localType = (*((const 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: */