sl@0: /* sl@0: * tclWinReg.c -- sl@0: * sl@0: * This file contains the implementation of the "registry" Tcl sl@0: * built-in command. This command is built as a dynamically sl@0: * loadable extension in a separate DLL. sl@0: * sl@0: * Copyright (c) 1997 by Sun Microsystems, Inc. sl@0: * Copyright (c) 1998-1999 by Scriptics Corporation. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclWinReg.c,v 1.21.2.7 2007/05/15 16:08:22 dgp Exp $ sl@0: */ sl@0: sl@0: #include sl@0: #include sl@0: sl@0: /* sl@0: * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the sl@0: * Registry_Init declaration is in the source file itself, which is only sl@0: * accessed when we are building a library. sl@0: */ sl@0: sl@0: #undef TCL_STORAGE_CLASS sl@0: #define TCL_STORAGE_CLASS DLLEXPORT sl@0: sl@0: /* sl@0: * The following macros convert between different endian ints. sl@0: */ sl@0: sl@0: #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) sl@0: #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) sl@0: sl@0: /* sl@0: * The following flag is used in OpenKeys to indicate that the specified sl@0: * key should be created if it doesn't currently exist. sl@0: */ sl@0: sl@0: #define REG_CREATE 1 sl@0: sl@0: /* sl@0: * The following tables contain the mapping from registry root names sl@0: * to the system predefined keys. sl@0: */ sl@0: sl@0: static CONST char *rootKeyNames[] = { sl@0: "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT", sl@0: "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", sl@0: "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL sl@0: }; sl@0: sl@0: static HKEY rootKeys[] = { sl@0: HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, sl@0: HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA sl@0: }; sl@0: sl@0: /* sl@0: * The following table maps from registry types to strings. Note that sl@0: * the indices for this array are the same as the constants for the sl@0: * known registry types so we don't need a separate table to hold the sl@0: * mapping. sl@0: */ sl@0: sl@0: static CONST char *typeNames[] = { sl@0: "none", "sz", "expand_sz", "binary", "dword", sl@0: "dword_big_endian", "link", "multi_sz", "resource_list", NULL sl@0: }; sl@0: sl@0: static DWORD lastType = REG_RESOURCE_LIST; sl@0: sl@0: /* sl@0: * The following structures allow us to select between the Unicode and ASCII sl@0: * interfaces at run time based on whether Unicode APIs are available. The sl@0: * Unicode APIs are preferable because they will handle characters outside sl@0: * of the current code page. sl@0: */ sl@0: sl@0: typedef struct RegWinProcs { sl@0: int useWide; sl@0: sl@0: LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY); sl@0: LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *, sl@0: DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *); sl@0: LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *); sl@0: LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *); sl@0: LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD); sl@0: LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, sl@0: TCHAR *, DWORD *, FILETIME *); sl@0: LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, sl@0: DWORD *, BYTE *, DWORD *); sl@0: LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM, sl@0: HKEY *); sl@0: LONG (WINAPI *regQueryInfoKeyProc)(HKEY, TCHAR *, DWORD *, DWORD *, sl@0: DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, sl@0: FILETIME *); sl@0: LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *, sl@0: BYTE *, DWORD *); sl@0: LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD, sl@0: CONST BYTE*, DWORD); sl@0: } RegWinProcs; sl@0: sl@0: static RegWinProcs *regWinProcs; sl@0: sl@0: static RegWinProcs asciiProcs = { sl@0: 0, sl@0: sl@0: (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA, sl@0: (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, sl@0: DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, sl@0: DWORD *)) RegCreateKeyExA, sl@0: (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA, sl@0: (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA, sl@0: (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA, sl@0: (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, sl@0: TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA, sl@0: (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, sl@0: DWORD *, BYTE *, DWORD *)) RegEnumValueA, sl@0: (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, sl@0: HKEY *)) RegOpenKeyExA, sl@0: (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *, sl@0: DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, sl@0: FILETIME *)) RegQueryInfoKeyA, sl@0: (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, sl@0: BYTE *, DWORD *)) RegQueryValueExA, sl@0: (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, sl@0: CONST BYTE*, DWORD)) RegSetValueExA, sl@0: }; sl@0: sl@0: static RegWinProcs unicodeProcs = { sl@0: 1, sl@0: sl@0: (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW, sl@0: (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, sl@0: DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, sl@0: DWORD *)) RegCreateKeyExW, sl@0: (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW, sl@0: (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW, sl@0: (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW, sl@0: (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, sl@0: TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW, sl@0: (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, sl@0: DWORD *, BYTE *, DWORD *)) RegEnumValueW, sl@0: (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, sl@0: HKEY *)) RegOpenKeyExW, sl@0: (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *, sl@0: DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, sl@0: FILETIME *)) RegQueryInfoKeyW, sl@0: (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, sl@0: BYTE *, DWORD *)) RegQueryValueExW, sl@0: (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, sl@0: CONST BYTE*, DWORD)) RegSetValueExW, sl@0: }; sl@0: sl@0: sl@0: /* sl@0: * Declarations for functions defined in this file. sl@0: */ sl@0: sl@0: static void AppendSystemError(Tcl_Interp *interp, DWORD error); sl@0: static int BroadcastValue(Tcl_Interp *interp, int objc, sl@0: Tcl_Obj * CONST objv[]); sl@0: static DWORD ConvertDWORD(DWORD type, DWORD value); sl@0: static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj); sl@0: static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, sl@0: Tcl_Obj *valueNameObj); sl@0: static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, sl@0: Tcl_Obj *patternObj); sl@0: static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj, sl@0: Tcl_Obj *valueNameObj); sl@0: static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, sl@0: Tcl_Obj *valueNameObj); sl@0: static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, sl@0: Tcl_Obj *patternObj); sl@0: static int OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, sl@0: REGSAM mode, int flags, HKEY *keyPtr); sl@0: static DWORD OpenSubKey(char *hostName, HKEY rootKey, sl@0: char *keyName, REGSAM mode, int flags, sl@0: HKEY *keyPtr); sl@0: static int ParseKeyName(Tcl_Interp *interp, char *name, sl@0: char **hostNamePtr, HKEY *rootKeyPtr, sl@0: char **keyNamePtr); sl@0: static DWORD RecursiveDeleteKey(HKEY hStartKey, sl@0: CONST TCHAR * pKeyName); sl@0: static int RegistryObjCmd(ClientData clientData, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj * CONST objv[]); sl@0: static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, sl@0: Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, sl@0: Tcl_Obj *typeObj); sl@0: sl@0: EXTERN int Registry_Init(Tcl_Interp *interp); sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Registry_Init -- sl@0: * sl@0: * This procedure initializes the registry command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Registry_Init( sl@0: Tcl_Interp *interp) sl@0: { sl@0: if (!Tcl_InitStubs(interp, "8.0", 0)) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Determine if the unicode interfaces are available and select the sl@0: * appropriate registry function table. sl@0: */ sl@0: sl@0: if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { sl@0: regWinProcs = &unicodeProcs; sl@0: } else { sl@0: regWinProcs = &asciiProcs; sl@0: } sl@0: sl@0: Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL); sl@0: return Tcl_PkgProvide(interp, "registry", "1.1.5"); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * RegistryObjCmd -- sl@0: * sl@0: * This function implements the Tcl "registry" command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: RegistryObjCmd( sl@0: ClientData clientData, /* Not used. */ sl@0: Tcl_Interp *interp, /* Current interpreter. */ sl@0: int objc, /* Number of arguments. */ sl@0: Tcl_Obj * CONST objv[]) /* Argument values. */ sl@0: { sl@0: int index; sl@0: char *errString; sl@0: sl@0: static CONST char *subcommands[] = { sl@0: "broadcast", "delete", "get", "keys", "set", "type", "values", sl@0: (char *) NULL sl@0: }; sl@0: enum SubCmdIdx { sl@0: BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx sl@0: }; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index) sl@0: != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: switch (index) { sl@0: case BroadcastIdx: /* broadcast */ sl@0: return BroadcastValue(interp, objc, objv); sl@0: break; sl@0: case DeleteIdx: /* delete */ sl@0: if (objc == 3) { sl@0: return DeleteKey(interp, objv[2]); sl@0: } else if (objc == 4) { sl@0: return DeleteValue(interp, objv[2], objv[3]); sl@0: } sl@0: errString = "keyName ?valueName?"; sl@0: break; sl@0: case GetIdx: /* get */ sl@0: if (objc == 4) { sl@0: return GetValue(interp, objv[2], objv[3]); sl@0: } sl@0: errString = "keyName valueName"; sl@0: break; sl@0: case KeysIdx: /* keys */ sl@0: if (objc == 3) { sl@0: return GetKeyNames(interp, objv[2], NULL); sl@0: } else if (objc == 4) { sl@0: return GetKeyNames(interp, objv[2], objv[3]); sl@0: } sl@0: errString = "keyName ?pattern?"; sl@0: break; sl@0: case SetIdx: /* set */ sl@0: if (objc == 3) { sl@0: HKEY key; sl@0: sl@0: /* sl@0: * Create the key and then close it immediately. sl@0: */ sl@0: sl@0: if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) sl@0: != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: RegCloseKey(key); sl@0: return TCL_OK; sl@0: } else if (objc == 5 || objc == 6) { sl@0: Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5]; sl@0: return SetValue(interp, objv[2], objv[3], objv[4], typeObj); sl@0: } sl@0: errString = "keyName ?valueName data ?type??"; sl@0: break; sl@0: case TypeIdx: /* type */ sl@0: if (objc == 4) { sl@0: return GetType(interp, objv[2], objv[3]); sl@0: } sl@0: errString = "keyName valueName"; sl@0: break; sl@0: case ValuesIdx: /* values */ sl@0: if (objc == 3) { sl@0: return GetValueNames(interp, objv[2], NULL); sl@0: } else if (objc == 4) { sl@0: return GetValueNames(interp, objv[2], objv[3]); sl@0: } sl@0: errString = "keyName ?pattern?"; sl@0: break; sl@0: } sl@0: Tcl_WrongNumArgs(interp, 2, objv, errString); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * DeleteKey -- sl@0: * sl@0: * This function deletes a registry key. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: DeleteKey( sl@0: Tcl_Interp *interp, /* Current interpreter. */ sl@0: Tcl_Obj *keyNameObj) /* Name of key to delete. */ sl@0: { sl@0: char *tail, *buffer, *hostName, *keyName; sl@0: CONST char *nativeTail; sl@0: HKEY rootKey, subkey; sl@0: DWORD result; sl@0: int length; sl@0: Tcl_Obj *resultPtr; sl@0: Tcl_DString buf; sl@0: sl@0: /* sl@0: * Find the parent of the key being deleted and open it. sl@0: */ sl@0: sl@0: keyName = Tcl_GetStringFromObj(keyNameObj, &length); sl@0: buffer = ckalloc((unsigned int) length + 1); sl@0: strcpy(buffer, keyName); sl@0: sl@0: if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName) sl@0: != TCL_OK) { sl@0: ckfree(buffer); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: if (*keyName == '\0') { sl@0: Tcl_AppendToObj(resultPtr, "bad key: cannot delete root keys", -1); sl@0: ckfree(buffer); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: tail = strrchr(keyName, '\\'); sl@0: if (tail) { sl@0: *tail++ = '\0'; sl@0: } else { sl@0: tail = keyName; sl@0: keyName = NULL; sl@0: } sl@0: sl@0: result = OpenSubKey(hostName, rootKey, keyName, sl@0: KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey); sl@0: if (result != ERROR_SUCCESS) { sl@0: ckfree(buffer); sl@0: if (result == ERROR_FILE_NOT_FOUND) { sl@0: return TCL_OK; sl@0: } else { sl@0: Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1); sl@0: AppendSystemError(interp, result); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Now we recursively delete the key and everything below it. sl@0: */ sl@0: sl@0: nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf); sl@0: result = RecursiveDeleteKey(subkey, nativeTail); sl@0: Tcl_DStringFree(&buf); sl@0: sl@0: if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { sl@0: Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1); sl@0: AppendSystemError(interp, result); sl@0: result = TCL_ERROR; sl@0: } else { sl@0: result = TCL_OK; sl@0: } sl@0: sl@0: RegCloseKey(subkey); sl@0: ckfree(buffer); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * DeleteValue -- sl@0: * sl@0: * This function deletes a value from a registry key. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: DeleteValue( sl@0: Tcl_Interp *interp, /* Current interpreter. */ sl@0: Tcl_Obj *keyNameObj, /* Name of key. */ sl@0: Tcl_Obj *valueNameObj) /* Name of value to delete. */ sl@0: { sl@0: HKEY key; sl@0: char *valueName; sl@0: int length; sl@0: DWORD result; sl@0: Tcl_Obj *resultPtr; sl@0: Tcl_DString ds; sl@0: sl@0: /* sl@0: * Attempt to open the key for deletion. sl@0: */ sl@0: sl@0: if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key) sl@0: != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: valueName = Tcl_GetStringFromObj(valueNameObj, &length); sl@0: Tcl_WinUtfToTChar(valueName, length, &ds); sl@0: result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds)); sl@0: Tcl_DStringFree(&ds); sl@0: if (result != ERROR_SUCCESS) { sl@0: Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"", sl@0: Tcl_GetString(valueNameObj), "\" from key \"", sl@0: Tcl_GetString(keyNameObj), "\": ", NULL); sl@0: AppendSystemError(interp, result); sl@0: result = TCL_ERROR; sl@0: } else { sl@0: result = TCL_OK; sl@0: } sl@0: RegCloseKey(key); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetKeyNames -- sl@0: * sl@0: * This function enumerates the subkeys of a given key. If the sl@0: * optional pattern is supplied, then only keys that match the sl@0: * pattern will be returned. sl@0: * sl@0: * Results: sl@0: * Returns the list of subkeys in the result object of the sl@0: * interpreter, or an error message on failure. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: GetKeyNames( sl@0: Tcl_Interp *interp, /* Current interpreter. */ sl@0: Tcl_Obj *keyNameObj, /* Key to enumerate. */ sl@0: Tcl_Obj *patternObj) /* Optional match pattern. */ sl@0: { sl@0: char *pattern; /* Pattern being matched against subkeys */ sl@0: HKEY key; /* Handle to the key being examined */ sl@0: DWORD subKeyCount; /* Number of subkeys to list */ sl@0: DWORD maxSubKeyLen; /* Maximum string length of any subkey */ sl@0: char *buffer; /* Buffer to hold the subkey name */ sl@0: DWORD bufSize; /* Size of the buffer */ sl@0: DWORD index; /* Position of the current subkey */ sl@0: char *name; /* Subkey name */ sl@0: Tcl_Obj *resultPtr; /* List of subkeys being accumulated */ sl@0: int result = TCL_OK; /* Return value from this command */ sl@0: Tcl_DString ds; /* Buffer to translate subkey name to UTF-8 */ sl@0: sl@0: if (patternObj) { sl@0: pattern = Tcl_GetString(patternObj); sl@0: } else { sl@0: pattern = NULL; sl@0: } sl@0: sl@0: /* Attempt to open the key for enumeration. */ sl@0: sl@0: if (OpenKey(interp, keyNameObj, sl@0: KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS, sl@0: 0, &key) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Determine how big a buffer is needed for enumerating subkeys, and sl@0: * how many subkeys there are sl@0: */ sl@0: sl@0: result = (*regWinProcs->regQueryInfoKeyProc) sl@0: (key, NULL, NULL, NULL, &subKeyCount, &maxSubKeyLen, NULL, NULL, sl@0: NULL, NULL, NULL, NULL); sl@0: if (result != ERROR_SUCCESS) { sl@0: Tcl_SetObjResult(interp, Tcl_NewObj()); sl@0: Tcl_AppendResult(interp, "unable to query key \"", sl@0: Tcl_GetString(keyNameObj), "\": ", NULL); sl@0: AppendSystemError(interp, result); sl@0: RegCloseKey(key); sl@0: return TCL_ERROR; sl@0: } sl@0: if (regWinProcs->useWide) { sl@0: buffer = ckalloc((maxSubKeyLen+1) * sizeof(WCHAR)); sl@0: } else { sl@0: buffer = ckalloc(maxSubKeyLen+1); sl@0: } sl@0: sl@0: /* Enumerate the subkeys */ sl@0: sl@0: resultPtr = Tcl_NewObj(); sl@0: for (index = 0; index < subKeyCount; ++index) { sl@0: bufSize = maxSubKeyLen+1; sl@0: result = (*regWinProcs->regEnumKeyExProc) sl@0: (key, index, buffer, &bufSize, NULL, NULL, NULL, NULL); sl@0: if (result != ERROR_SUCCESS) { sl@0: Tcl_SetObjResult(interp, Tcl_NewObj()); sl@0: Tcl_AppendResult(interp, sl@0: "unable to enumerate subkeys of \"", sl@0: Tcl_GetString(keyNameObj), sl@0: "\": ", NULL); sl@0: AppendSystemError(interp, result); sl@0: result = TCL_ERROR; sl@0: break; sl@0: } sl@0: if (regWinProcs->useWide) { sl@0: Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize * sizeof(WCHAR), &ds); sl@0: } else { sl@0: Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize, &ds); sl@0: } sl@0: name = Tcl_DStringValue(&ds); sl@0: if (pattern && !Tcl_StringMatch(name, pattern)) { sl@0: Tcl_DStringFree(&ds); sl@0: continue; sl@0: } sl@0: result = Tcl_ListObjAppendElement(interp, resultPtr, sl@0: Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); sl@0: Tcl_DStringFree(&ds); sl@0: if (result != TCL_OK) { sl@0: break; sl@0: } sl@0: } sl@0: if (result == TCL_OK) { sl@0: Tcl_SetObjResult(interp, resultPtr); sl@0: } sl@0: sl@0: ckfree(buffer); sl@0: RegCloseKey(key); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetType -- sl@0: * sl@0: * This function gets the type of a given registry value and sl@0: * places it in the interpreter result. sl@0: * sl@0: * Results: sl@0: * Returns a normal Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: GetType( sl@0: Tcl_Interp *interp, /* Current interpreter. */ sl@0: Tcl_Obj *keyNameObj, /* Name of key. */ sl@0: Tcl_Obj *valueNameObj) /* Name of value to get. */ sl@0: { sl@0: HKEY key; sl@0: Tcl_Obj *resultPtr; sl@0: DWORD result; sl@0: DWORD type; sl@0: Tcl_DString ds; sl@0: char *valueName; sl@0: CONST char *nativeValue; sl@0: int length; sl@0: sl@0: /* sl@0: * Attempt to open the key for reading. sl@0: */ sl@0: sl@0: if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) sl@0: != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Get the type of the value. sl@0: */ sl@0: sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: sl@0: valueName = Tcl_GetStringFromObj(valueNameObj, &length); sl@0: nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds); sl@0: result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type, sl@0: NULL, NULL); sl@0: Tcl_DStringFree(&ds); sl@0: RegCloseKey(key); sl@0: sl@0: if (result != ERROR_SUCCESS) { sl@0: Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"", sl@0: Tcl_GetString(valueNameObj), "\" from key \"", sl@0: Tcl_GetString(keyNameObj), "\": ", NULL); sl@0: AppendSystemError(interp, result); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Set the type into the result. Watch out for unknown types. sl@0: * If we don't know about the type, just use the numeric value. sl@0: */ sl@0: sl@0: if (type > lastType || type < 0) { sl@0: Tcl_SetIntObj(resultPtr, (int) type); sl@0: } else { sl@0: Tcl_SetStringObj(resultPtr, typeNames[type], -1); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetValue -- sl@0: * sl@0: * This function gets the contents of a registry value and places sl@0: * a list containing the data and the type in the interpreter sl@0: * result. sl@0: * sl@0: * Results: sl@0: * Returns a normal Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: GetValue( sl@0: Tcl_Interp *interp, /* Current interpreter. */ sl@0: Tcl_Obj *keyNameObj, /* Name of key. */ sl@0: Tcl_Obj *valueNameObj) /* Name of value to get. */ sl@0: { sl@0: HKEY key; sl@0: char *valueName; sl@0: CONST char *nativeValue; sl@0: DWORD result, length, type; sl@0: Tcl_Obj *resultPtr; sl@0: Tcl_DString data, buf; sl@0: int nameLen; sl@0: sl@0: /* sl@0: * Attempt to open the key for reading. sl@0: */ sl@0: sl@0: if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) sl@0: != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Initialize a Dstring to maximum statically allocated size sl@0: * we could get one more byte by avoiding Tcl_DStringSetLength() sl@0: * and just setting length to TCL_DSTRING_STATIC_SIZE, but this sl@0: * should be safer if the implementation of Dstrings changes. sl@0: * sl@0: * This allows short values to be read from the registy in one call. sl@0: * Longer values need a second call with an expanded DString. sl@0: */ sl@0: sl@0: Tcl_DStringInit(&data); sl@0: length = TCL_DSTRING_STATIC_SIZE - 1; sl@0: Tcl_DStringSetLength(&data, (int) length); sl@0: sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: sl@0: valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen); sl@0: nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf); sl@0: sl@0: result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type, sl@0: (BYTE *) Tcl_DStringValue(&data), &length); sl@0: while (result == ERROR_MORE_DATA) { sl@0: /* sl@0: * The Windows docs say that in this error case, we just need sl@0: * to expand our buffer and request more data. sl@0: * Required for HKEY_PERFORMANCE_DATA sl@0: */ sl@0: length *= 2; sl@0: Tcl_DStringSetLength(&data, (int) length); sl@0: result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue, sl@0: NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); sl@0: } sl@0: Tcl_DStringFree(&buf); sl@0: RegCloseKey(key); sl@0: if (result != ERROR_SUCCESS) { sl@0: Tcl_AppendStringsToObj(resultPtr, "unable to get value \"", sl@0: Tcl_GetString(valueNameObj), "\" from key \"", sl@0: Tcl_GetString(keyNameObj), "\": ", NULL); sl@0: AppendSystemError(interp, result); sl@0: Tcl_DStringFree(&data); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * If the data is a 32-bit quantity, store it as an integer object. If it sl@0: * is a multi-string, store it as a list of strings. For null-terminated sl@0: * strings, append up the to first null. Otherwise, store it as a binary sl@0: * string. sl@0: */ sl@0: sl@0: if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { sl@0: Tcl_SetIntObj(resultPtr, (int) ConvertDWORD(type, sl@0: *((DWORD*) Tcl_DStringValue(&data)))); sl@0: } else if (type == REG_MULTI_SZ) { sl@0: char *p = Tcl_DStringValue(&data); sl@0: char *end = Tcl_DStringValue(&data) + length; sl@0: sl@0: /* sl@0: * Multistrings are stored as an array of null-terminated strings, sl@0: * terminated by two null characters. Also do a bounds check in sl@0: * case we get bogus data. sl@0: */ sl@0: sl@0: while (p < end && ((regWinProcs->useWide) sl@0: ? *((Tcl_UniChar *)p) : *p) != 0) { sl@0: Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); sl@0: Tcl_ListObjAppendElement(interp, resultPtr, sl@0: Tcl_NewStringObj(Tcl_DStringValue(&buf), sl@0: Tcl_DStringLength(&buf))); sl@0: if (regWinProcs->useWide) { sl@0: while (*((Tcl_UniChar *)p)++ != 0) {} sl@0: } else { sl@0: while (*p++ != '\0') {} sl@0: } sl@0: Tcl_DStringFree(&buf); sl@0: } sl@0: } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { sl@0: Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf); sl@0: Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buf), sl@0: Tcl_DStringLength(&buf)); sl@0: Tcl_DStringFree(&buf); sl@0: } else { sl@0: /* sl@0: * Save binary data as a byte array. sl@0: */ sl@0: sl@0: Tcl_SetByteArrayObj(resultPtr, Tcl_DStringValue(&data), (int) length); sl@0: } sl@0: Tcl_DStringFree(&data); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetValueNames -- sl@0: * sl@0: * This function enumerates the values of the a given key. If sl@0: * the optional pattern is supplied, then only value names that sl@0: * match the pattern will be returned. sl@0: * sl@0: * Results: sl@0: * Returns the list of value names in the result object of the sl@0: * interpreter, or an error message on failure. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: GetValueNames( sl@0: Tcl_Interp *interp, /* Current interpreter. */ sl@0: Tcl_Obj *keyNameObj, /* Key to enumerate. */ sl@0: Tcl_Obj *patternObj) /* Optional match pattern. */ sl@0: { sl@0: HKEY key; sl@0: Tcl_Obj *resultPtr; sl@0: DWORD index, size, maxSize, result; sl@0: Tcl_DString buffer, ds; sl@0: char *pattern, *name; sl@0: sl@0: /* sl@0: * Attempt to open the key for enumeration. sl@0: */ sl@0: sl@0: if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) sl@0: != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: sl@0: /* sl@0: * Query the key to determine the appropriate buffer size to hold the sl@0: * largest value name plus the terminating null. sl@0: */ sl@0: sl@0: result = (*regWinProcs->regQueryInfoKeyProc)(key, NULL, NULL, NULL, NULL, sl@0: NULL, NULL, &index, &maxSize, NULL, NULL, NULL); sl@0: if (result != ERROR_SUCCESS) { sl@0: Tcl_AppendStringsToObj(resultPtr, "unable to query key \"", sl@0: Tcl_GetString(keyNameObj), "\": ", NULL); sl@0: AppendSystemError(interp, result); sl@0: RegCloseKey(key); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: maxSize++; sl@0: sl@0: sl@0: Tcl_DStringInit(&buffer); sl@0: Tcl_DStringSetLength(&buffer, sl@0: (int) ((regWinProcs->useWide) ? maxSize*2 : maxSize)); sl@0: index = 0; sl@0: result = TCL_OK; sl@0: sl@0: if (patternObj) { sl@0: pattern = Tcl_GetString(patternObj); sl@0: } else { sl@0: pattern = NULL; sl@0: } sl@0: sl@0: /* sl@0: * Enumerate the values under the given subkey until we get an error, sl@0: * indicating the end of the list. Note that we need to reset size sl@0: * after each iteration because RegEnumValue smashes the old value. sl@0: */ sl@0: sl@0: size = maxSize; sl@0: while ((*regWinProcs->regEnumValueProc)(key, index, sl@0: Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) sl@0: == ERROR_SUCCESS) { sl@0: sl@0: if (regWinProcs->useWide) { sl@0: size *= 2; sl@0: } sl@0: sl@0: Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, &ds); sl@0: name = Tcl_DStringValue(&ds); sl@0: if (!pattern || Tcl_StringMatch(name, pattern)) { sl@0: result = Tcl_ListObjAppendElement(interp, resultPtr, sl@0: Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); sl@0: if (result != TCL_OK) { sl@0: Tcl_DStringFree(&ds); sl@0: break; sl@0: } sl@0: } sl@0: Tcl_DStringFree(&ds); sl@0: sl@0: index++; sl@0: size = maxSize; sl@0: } sl@0: Tcl_DStringFree(&buffer); sl@0: sl@0: done: sl@0: RegCloseKey(key); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * OpenKey -- sl@0: * sl@0: * This function opens the specified key. This function is a sl@0: * simple wrapper around ParseKeyName and OpenSubKey. sl@0: * sl@0: * Results: sl@0: * Returns the opened key in the keyPtr argument and a Tcl sl@0: * result code. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: OpenKey( sl@0: Tcl_Interp *interp, /* Current interpreter. */ sl@0: Tcl_Obj *keyNameObj, /* Key to open. */ sl@0: REGSAM mode, /* Access mode. */ sl@0: int flags, /* 0 or REG_CREATE. */ sl@0: HKEY *keyPtr) /* Returned HKEY. */ sl@0: { sl@0: char *keyName, *buffer, *hostName; sl@0: int length; sl@0: HKEY rootKey; sl@0: DWORD result; sl@0: sl@0: keyName = Tcl_GetStringFromObj(keyNameObj, &length); sl@0: buffer = ckalloc((unsigned int) length + 1); sl@0: strcpy(buffer, keyName); sl@0: sl@0: result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); sl@0: if (result == TCL_OK) { sl@0: result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr); sl@0: if (result != ERROR_SUCCESS) { sl@0: Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); sl@0: Tcl_AppendToObj(resultPtr, "unable to open key: ", -1); sl@0: AppendSystemError(interp, result); sl@0: result = TCL_ERROR; sl@0: } else { sl@0: result = TCL_OK; sl@0: } sl@0: } sl@0: sl@0: ckfree(buffer); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * OpenSubKey -- sl@0: * sl@0: * This function opens a given subkey of a root key on the sl@0: * specified host. sl@0: * sl@0: * Results: sl@0: * Returns the opened key in the keyPtr and a Windows error code sl@0: * as the return value. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static DWORD sl@0: OpenSubKey( sl@0: char *hostName, /* Host to access, or NULL for local. */ sl@0: HKEY rootKey, /* Root registry key. */ sl@0: char *keyName, /* Subkey name. */ sl@0: REGSAM mode, /* Access mode. */ sl@0: int flags, /* 0 or REG_CREATE. */ sl@0: HKEY *keyPtr) /* Returned HKEY. */ sl@0: { sl@0: DWORD result; sl@0: Tcl_DString buf; sl@0: sl@0: /* sl@0: * Attempt to open the root key on a remote host if necessary. sl@0: */ sl@0: sl@0: if (hostName) { sl@0: hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf); sl@0: result = (*regWinProcs->regConnectRegistryProc)(hostName, rootKey, sl@0: &rootKey); sl@0: Tcl_DStringFree(&buf); sl@0: if (result != ERROR_SUCCESS) { sl@0: return result; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Now open the specified key with the requested permissions. Note sl@0: * that this key must be closed by the caller. sl@0: */ sl@0: sl@0: keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); sl@0: if (flags & REG_CREATE) { sl@0: DWORD create; sl@0: result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL, sl@0: REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); sl@0: } else { sl@0: if (rootKey == HKEY_PERFORMANCE_DATA) { sl@0: /* sl@0: * Here we fudge it for this special root key. sl@0: * See MSDN for more info on HKEY_PERFORMANCE_DATA and sl@0: * the peculiarities surrounding it sl@0: */ sl@0: *keyPtr = HKEY_PERFORMANCE_DATA; sl@0: result = ERROR_SUCCESS; sl@0: } else { sl@0: result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, sl@0: mode, keyPtr); sl@0: } sl@0: } sl@0: Tcl_DStringFree(&buf); sl@0: sl@0: /* sl@0: * Be sure to close the root key since we are done with it now. sl@0: */ sl@0: sl@0: if (hostName) { sl@0: RegCloseKey(rootKey); sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * ParseKeyName -- sl@0: * sl@0: * This function parses a key name into the host, root, and subkey sl@0: * parts. sl@0: * sl@0: * Results: sl@0: * The pointers to the start of the host and subkey names are sl@0: * returned in the hostNamePtr and keyNamePtr variables. The sl@0: * specified root HKEY is returned in rootKeyPtr. Returns sl@0: * a standard Tcl result. sl@0: * sl@0: * sl@0: * Side effects: sl@0: * Modifies the name string by inserting nulls. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: ParseKeyName( sl@0: Tcl_Interp *interp, /* Current interpreter. */ sl@0: char *name, sl@0: char **hostNamePtr, sl@0: HKEY *rootKeyPtr, sl@0: char **keyNamePtr) sl@0: { sl@0: char *rootName; sl@0: int result, index; sl@0: Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp); sl@0: sl@0: /* sl@0: * Split the key into host and root portions. sl@0: */ sl@0: sl@0: *hostNamePtr = *keyNamePtr = rootName = NULL; sl@0: if (name[0] == '\\') { sl@0: if (name[1] == '\\') { sl@0: *hostNamePtr = name; sl@0: for (rootName = name+2; *rootName != '\0'; rootName++) { sl@0: if (*rootName == '\\') { sl@0: *rootName++ = '\0'; sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: } else { sl@0: rootName = name; sl@0: } sl@0: if (!rootName) { sl@0: Tcl_AppendStringsToObj(resultPtr, "bad key \"", name, sl@0: "\": must start with a valid root", NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Split the root into root and subkey portions. sl@0: */ sl@0: sl@0: for (*keyNamePtr = rootName; **keyNamePtr != '\0'; (*keyNamePtr)++) { sl@0: if (**keyNamePtr == '\\') { sl@0: **keyNamePtr = '\0'; sl@0: (*keyNamePtr)++; sl@0: break; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Look for a matching root name. sl@0: */ sl@0: sl@0: rootObj = Tcl_NewStringObj(rootName, -1); sl@0: result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name", sl@0: TCL_EXACT, &index); sl@0: Tcl_DecrRefCount(rootObj); sl@0: if (result != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: *rootKeyPtr = rootKeys[index]; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * RecursiveDeleteKey -- sl@0: * sl@0: * This function recursively deletes all the keys below a starting sl@0: * key. Although Windows 95 does this automatically, we still need sl@0: * to do this for Windows NT. sl@0: * sl@0: * Results: sl@0: * Returns a Windows error code. sl@0: * sl@0: * Side effects: sl@0: * Deletes all of the keys and values below the given key. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static DWORD sl@0: RecursiveDeleteKey( sl@0: HKEY startKey, /* Parent of key to be deleted. */ sl@0: CONST char *keyName) /* Name of key to be deleted in external sl@0: * encoding, not UTF. */ sl@0: { sl@0: DWORD result, size, maxSize; sl@0: Tcl_DString subkey; sl@0: HKEY hKey; sl@0: sl@0: /* sl@0: * Do not allow NULL or empty key name. sl@0: */ sl@0: sl@0: if (!keyName || *keyName == '\0') { sl@0: return ERROR_BADKEY; sl@0: } sl@0: sl@0: result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0, sl@0: KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey); sl@0: if (result != ERROR_SUCCESS) { sl@0: return result; sl@0: } sl@0: result = (*regWinProcs->regQueryInfoKeyProc)(hKey, NULL, NULL, NULL, NULL, sl@0: &maxSize, NULL, NULL, NULL, NULL, NULL, NULL); sl@0: maxSize++; sl@0: if (result != ERROR_SUCCESS) { sl@0: return result; sl@0: } sl@0: sl@0: Tcl_DStringInit(&subkey); sl@0: Tcl_DStringSetLength(&subkey, sl@0: (int) ((regWinProcs->useWide) ? maxSize * 2 : maxSize)); sl@0: sl@0: while (result == ERROR_SUCCESS) { sl@0: /* sl@0: * Always get index 0 because key deletion changes ordering. sl@0: */ sl@0: sl@0: size = maxSize; sl@0: result=(*regWinProcs->regEnumKeyExProc)(hKey, 0, sl@0: Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); sl@0: if (result == ERROR_NO_MORE_ITEMS) { sl@0: result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName); sl@0: break; sl@0: } else if (result == ERROR_SUCCESS) { sl@0: result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey)); sl@0: } sl@0: } sl@0: Tcl_DStringFree(&subkey); sl@0: RegCloseKey(hKey); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SetValue -- sl@0: * sl@0: * This function sets the contents of a registry value. If sl@0: * the key or value does not exist, it will be created. If it sl@0: * does exist, then the data and type will be replaced. sl@0: * sl@0: * Results: sl@0: * Returns a normal Tcl result. sl@0: * sl@0: * Side effects: sl@0: * May create new keys or values. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SetValue( sl@0: Tcl_Interp *interp, /* Current interpreter. */ sl@0: Tcl_Obj *keyNameObj, /* Name of key. */ sl@0: Tcl_Obj *valueNameObj, /* Name of value to set. */ sl@0: Tcl_Obj *dataObj, /* Data to be written. */ sl@0: Tcl_Obj *typeObj) /* Type of data to be written. */ sl@0: { sl@0: DWORD type, result; sl@0: HKEY key; sl@0: int length; sl@0: char *valueName; sl@0: Tcl_Obj *resultPtr; sl@0: Tcl_DString nameBuf; sl@0: sl@0: if (typeObj == NULL) { sl@0: type = REG_SZ; sl@0: } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type", sl@0: 0, (int *) &type) != TCL_OK) { sl@0: if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_ResetResult(interp); sl@0: } sl@0: if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: valueName = Tcl_GetStringFromObj(valueNameObj, &length); sl@0: valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf); sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: sl@0: if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { sl@0: DWORD value; sl@0: if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) { sl@0: RegCloseKey(key); sl@0: Tcl_DStringFree(&nameBuf); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: value = ConvertDWORD(type, value); sl@0: result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, sl@0: (BYTE*) &value, sizeof(DWORD)); sl@0: } else if (type == REG_MULTI_SZ) { sl@0: Tcl_DString data, buf; sl@0: int objc, i; sl@0: Tcl_Obj **objv; sl@0: sl@0: if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) { sl@0: RegCloseKey(key); sl@0: Tcl_DStringFree(&nameBuf); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Append the elements as null terminated strings. Note that sl@0: * we must not assume the length of the string in case there are sl@0: * embedded nulls, which aren't allowed in REG_MULTI_SZ values. sl@0: */ sl@0: sl@0: Tcl_DStringInit(&data); sl@0: for (i = 0; i < objc; i++) { sl@0: Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1); sl@0: sl@0: /* sl@0: * Add a null character to separate this value from the next. sl@0: * We accomplish this by growing the string by one byte. Since the sl@0: * DString always tacks on an extra null byte, the new byte will sl@0: * already be set to null. sl@0: */ sl@0: sl@0: Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1); sl@0: } sl@0: sl@0: Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, sl@0: &buf); sl@0: result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, sl@0: (BYTE *) Tcl_DStringValue(&buf), sl@0: (DWORD) Tcl_DStringLength(&buf)); sl@0: Tcl_DStringFree(&data); sl@0: Tcl_DStringFree(&buf); sl@0: } else if (type == REG_SZ || type == REG_EXPAND_SZ) { sl@0: Tcl_DString buf; sl@0: char *data = Tcl_GetStringFromObj(dataObj, &length); sl@0: sl@0: data = (char *) Tcl_WinUtfToTChar(data, length, &buf); sl@0: sl@0: /* sl@0: * Include the null in the length, padding if needed for Unicode. sl@0: */ sl@0: sl@0: if (regWinProcs->useWide) { sl@0: Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); sl@0: } sl@0: length = Tcl_DStringLength(&buf) + 1; sl@0: sl@0: result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, sl@0: (BYTE*)data, (DWORD) length); sl@0: Tcl_DStringFree(&buf); sl@0: } else { sl@0: char *data; sl@0: sl@0: /* sl@0: * Store binary data in the registry. sl@0: */ sl@0: sl@0: data = Tcl_GetByteArrayFromObj(dataObj, &length); sl@0: result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, sl@0: (BYTE *)data, (DWORD) length); sl@0: } sl@0: Tcl_DStringFree(&nameBuf); sl@0: RegCloseKey(key); sl@0: if (result != ERROR_SUCCESS) { sl@0: Tcl_AppendToObj(resultPtr, "unable to set value: ", -1); sl@0: AppendSystemError(interp, result); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * BroadcastValue -- sl@0: * sl@0: * This function broadcasts a WM_SETTINGCHANGE message to indicate sl@0: * to other programs that we have changed the contents of a registry sl@0: * value. sl@0: * sl@0: * Results: sl@0: * Returns a normal Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Will cause other programs to reload their system settings. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: BroadcastValue( sl@0: Tcl_Interp *interp, /* Current interpreter. */ sl@0: int objc, /* Number of arguments. */ sl@0: Tcl_Obj * CONST objv[]) /* Argument values. */ sl@0: { sl@0: LRESULT result, sendResult; sl@0: UINT timeout = 3000; sl@0: int len; sl@0: char *str; sl@0: Tcl_Obj *objPtr; sl@0: sl@0: if ((objc != 3) && (objc != 5)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (objc > 3) { sl@0: str = Tcl_GetStringFromObj(objv[3], &len); sl@0: if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", (size_t) len)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: str = Tcl_GetStringFromObj(objv[2], &len); sl@0: if (len == 0) { sl@0: str = NULL; sl@0: } sl@0: sl@0: /* sl@0: * Use the ignore the result. sl@0: */ sl@0: result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, sl@0: (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult); sl@0: sl@0: objPtr = Tcl_NewObj(); sl@0: Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result)); sl@0: Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult)); sl@0: Tcl_SetObjResult(interp, objPtr); sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * AppendSystemError -- sl@0: * sl@0: * This routine formats a Windows system error message and places sl@0: * it into the interpreter result. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: AppendSystemError( sl@0: Tcl_Interp *interp, /* Current interpreter. */ sl@0: DWORD error) /* Result code from error. */ sl@0: { sl@0: int length; sl@0: WCHAR *wMsgPtr; sl@0: char *msg; sl@0: char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; sl@0: Tcl_DString ds; sl@0: Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); sl@0: sl@0: length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM sl@0: | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, sl@0: MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) &wMsgPtr, sl@0: 0, NULL); sl@0: if (length == 0) { sl@0: char *msgPtr; sl@0: sl@0: length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM sl@0: | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, sl@0: MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr, sl@0: 0, NULL); sl@0: if (length > 0) { sl@0: wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR)); sl@0: MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr, sl@0: length + 1); sl@0: LocalFree(msgPtr); sl@0: } sl@0: } sl@0: if (length == 0) { sl@0: if (error == ERROR_CALL_NOT_IMPLEMENTED) { sl@0: msg = "function not supported under Win32s"; sl@0: } else { sl@0: sprintf(msgBuf, "unknown error: %ld", error); sl@0: msg = msgBuf; sl@0: } sl@0: } else { sl@0: Tcl_Encoding encoding; sl@0: sl@0: encoding = Tcl_GetEncoding(NULL, "unicode"); sl@0: Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds); sl@0: Tcl_FreeEncoding(encoding); sl@0: LocalFree(wMsgPtr); sl@0: sl@0: msg = Tcl_DStringValue(&ds); sl@0: length = Tcl_DStringLength(&ds); sl@0: sl@0: /* sl@0: * Trim the trailing CR/LF from the system message. sl@0: */ sl@0: if (msg[length-1] == '\n') { sl@0: msg[--length] = 0; sl@0: } sl@0: if (msg[length-1] == '\r') { sl@0: msg[--length] = 0; sl@0: } sl@0: } sl@0: sl@0: sprintf(id, "%ld", error); sl@0: Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL); sl@0: Tcl_AppendToObj(resultPtr, msg, length); sl@0: sl@0: if (length != 0) { sl@0: Tcl_DStringFree(&ds); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * ConvertDWORD -- sl@0: * sl@0: * This function determines whether a DWORD needs to be byte sl@0: * swapped, and returns the appropriately swapped value. sl@0: * sl@0: * Results: sl@0: * Returns a converted DWORD. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static DWORD sl@0: ConvertDWORD( sl@0: DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */ sl@0: DWORD value) /* The value to be converted. */ sl@0: { sl@0: DWORD order = 1; sl@0: DWORD localType; sl@0: sl@0: /* sl@0: * Check to see if the low bit is in the first byte. sl@0: */ sl@0: sl@0: localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN; sl@0: return (type != localType) ? SWAPLONG(value) : value; sl@0: }