--- projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinreg.c 2016/10/14 02:09:58 44 +++ projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinreg.c 2016/11/05 11:07:06 71 @@ -1,1427 +1,1417 @@ -/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclwinreg.c,v 1.1.1.1 2001/06/13 04:50:03 dtashley Exp $ */ - -/* - * 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. - * - * RCS: @(#) $Id: tclwinreg.c,v 1.1.1.1 2001/06/13 04:50:03 dtashley 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; - -/* - * The following structures allow us to select between the Unicode and ASCII - * interfaces at run time based on whether Unicode APIs are available. The - * Unicode APIs are preferable because they will handle characters outside - * of the current code page. - */ - -typedef struct RegWinProcs { - int useWide; - - LONG (WINAPI *regConnectRegistryProc)(TCHAR *, HKEY, PHKEY); - LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *); - LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *); - LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *); - LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD); - LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - TCHAR *, DWORD *, FILETIME *); - LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - DWORD *, BYTE *, DWORD *); - LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM, - HKEY *); - LONG (WINAPI *regQueryInfoKeyProc)(HKEY, TCHAR *, DWORD *, DWORD *, - DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, - FILETIME *); - LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *, - BYTE *, DWORD *); - LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD, - CONST BYTE*, DWORD); -} RegWinProcs; - -static RegWinProcs *regWinProcs; - -static RegWinProcs asciiProcs = { - 0, - - (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, - DWORD *)) RegCreateKeyExA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - DWORD *, BYTE *, DWORD *)) RegEnumValueA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, - HKEY *)) RegOpenKeyExA, - (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *, - DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, - FILETIME *)) RegQueryInfoKeyA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, - BYTE *, DWORD *)) RegQueryValueExA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, - CONST BYTE*, DWORD)) RegSetValueExA, -}; - -static RegWinProcs unicodeProcs = { - 1, - - (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, - DWORD *)) RegCreateKeyExW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - DWORD *, BYTE *, DWORD *)) RegEnumValueW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, - HKEY *)) RegOpenKeyExW, - (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *, - DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, - FILETIME *)) RegQueryInfoKeyW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, - BYTE *, DWORD *)) RegQueryValueExW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, - CONST BYTE*, DWORD)) RegSetValueExW, -}; - - -/* - * 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, TCHAR * 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; - } - - /* - * Determine if the unicode interfaces are available and select the - * appropriate registry function table. - */ - - if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { - regWinProcs = &unicodeProcs; - } else { - regWinProcs = &asciiProcs; - } - - 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; - Tcl_DString buf; - - /* - * 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. - */ - - tail = Tcl_WinUtfToTChar(tail, -1, &buf); - result = RecursiveDeleteKey(subkey, tail); - Tcl_DStringFree(&buf); - - 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; - Tcl_DString ds; - - /* - * 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); - Tcl_WinUtfToTChar(valueName, length, &ds); - result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds)); - Tcl_DStringFree(&ds); - if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", 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, *name; - Tcl_Obj *resultPtr; - int result = TCL_OK; - Tcl_DString ds; - - /* - * 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_GetString(patternObj); - } 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; (*regWinProcs->regEnumKeyProc)(key, index, buffer, - MAX_PATH+1) == ERROR_SUCCESS; index++) { - Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &ds); - name = Tcl_DStringValue(&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; - } - } - - 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; - Tcl_DString ds; - char *valueName; - int length; - - /* - * 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); - - valueName = Tcl_GetStringFromObj(valueNameObj, &length); - valueName = Tcl_WinUtfToTChar(valueName, length, &ds); - result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type, - NULL, NULL); - Tcl_DStringFree(&ds); - RegCloseKey(key); - - if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", 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, buf; - int nameLen; - - /* - * 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 of Dstrings changes. - * - * This allows short values to be read from the registy in one call. - * Longer values need a second call with an expanded DString. - */ - - Tcl_DStringInit(&data); - length = TCL_DSTRING_STATIC_SIZE - 1; - Tcl_DStringSetLength(&data, length); - - resultPtr = Tcl_GetObjResult(interp); - - valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen); - valueName = Tcl_WinUtfToTChar(valueName, nameLen, &buf); - - result = (*regWinProcs->regQueryValueExProc)(key, valueName, 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 *= 2; - Tcl_DStringSetLength(&data, length); - result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, - &type, (BYTE *) Tcl_DStringValue(&data), &length); - } - Tcl_DStringFree(&buf); - RegCloseKey(key); - if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to get value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", 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 *end = Tcl_DStringValue(&data) + length; - - /* - * 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 && ((regWinProcs->useWide) - ? *((Tcl_UniChar *)p) : *p) != 0) { - Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); - Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(Tcl_DStringValue(&buf), - Tcl_DStringLength(&buf))); - if (regWinProcs->useWide) { - while (*((Tcl_UniChar *)p)++ != 0) {} - } else { - while (*p++ != '\0') {} - } - Tcl_DStringFree(&buf); - } - } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buf), - Tcl_DStringLength(&buf)); - Tcl_DStringFree(&buf); - } else { - /* - * Save binary data as a byte array. - */ - - Tcl_SetByteArrayObj(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, maxSize, result; - Tcl_DString buffer, ds; - char *pattern, *name; - - /* - * 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 = (*regWinProcs->regQueryInfoKeyProc)(key, NULL, NULL, NULL, NULL, - NULL, NULL, &index, &maxSize, NULL, NULL, NULL); - if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to query key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); - AppendSystemError(interp, result); - RegCloseKey(key); - result = TCL_ERROR; - goto done; - } - maxSize++; - - - Tcl_DStringInit(&buffer); - Tcl_DStringSetLength(&buffer, - (regWinProcs->useWide) ? maxSize*2 : maxSize); - 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 = maxSize; - while ((*regWinProcs->regEnumValueProc)(key, index, - Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) - == ERROR_SUCCESS) { - - if (regWinProcs->useWide) { - size *= 2; - } - - Tcl_WinTCharToUtf((TCHAR *) 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 = maxSize; - } - 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; - Tcl_DString buf; - - /* - * Attempt to open the root key on a remote host if necessary. - */ - - if (hostName) { - hostName = Tcl_WinUtfToTChar(hostName, -1, &buf); - result = (*regWinProcs->regConnectRegistryProc)(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. - */ - - keyName = Tcl_WinUtfToTChar(keyName, -1, &buf); - if (flags & REG_CREATE) { - DWORD create; - result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, "", - 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 = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, - mode, keyPtr); - } - } - Tcl_DStringFree(&buf); - - /* - * 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 in external - * encoding, not UTF. */ -{ - DWORD result, size, maxSize; - Tcl_DString subkey; - HKEY hKey; - - /* - * Do not allow NULL or empty key name. - */ - - if (!keyName || *keyName == '\0') { - return ERROR_BADKEY; - } - - result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0, - KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey); - if (result != ERROR_SUCCESS) { - return result; - } - result = (*regWinProcs->regQueryInfoKeyProc)(hKey, NULL, NULL, NULL, NULL, - &maxSize, NULL, NULL, NULL, NULL, NULL, NULL); - maxSize++; - if (result != ERROR_SUCCESS) { - return result; - } - - Tcl_DStringInit(&subkey); - Tcl_DStringSetLength(&subkey, - (regWinProcs->useWide) ? maxSize * 2 : maxSize); - - while (result == ERROR_SUCCESS) { - /* - * Always get index 0 because key deletion changes ordering. - */ - - size = maxSize; - result=(*regWinProcs->regEnumKeyExProc)(hKey, 0, - Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); - if (result == ERROR_NO_MORE_ITEMS) { - result = (*regWinProcs->regDeleteKeyProc)(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; - Tcl_DString nameBuf; - - 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); - valueName = Tcl_WinUtfToTChar(valueName, length, &nameBuf); - resultPtr = Tcl_GetObjResult(interp); - - if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { - DWORD value; - if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) { - RegCloseKey(key); - Tcl_DStringFree(&nameBuf); - return TCL_ERROR; - } - - value = ConvertDWORD(type, value); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, - (BYTE*) &value, sizeof(DWORD)); - } else if (type == REG_MULTI_SZ) { - Tcl_DString data, buf; - int 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++) { - Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1); - - /* - * Add a null character to separate this value from the next. - * We accomplish this by growing the string by one byte. Since the - * DString always tacks on an extra null byte, the new byte will - * already be set to null. - */ - - Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1); - } - - Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, - &buf); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, - (BYTE *) Tcl_DStringValue(&buf), - (DWORD) Tcl_DStringLength(&buf)); - Tcl_DStringFree(&data); - Tcl_DStringFree(&buf); - } else if (type == REG_SZ || type == REG_EXPAND_SZ) { - Tcl_DString buf; - char *data = Tcl_GetStringFromObj(dataObj, &length); - - data = Tcl_WinUtfToTChar(data, length, &buf); - - /* - * Include the null in the length, padding if needed for Unicode. - */ - - if (regWinProcs->useWide) { - Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); - } - length = Tcl_DStringLength(&buf) + 1; - - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, - (BYTE*)data, length); - Tcl_DStringFree(&buf); - } else { - char *data; - - /* - * Store binary data in the registry. - */ - - data = Tcl_GetByteArrayFromObj(dataObj, &length); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, - (BYTE *)data, length); - } - Tcl_DStringFree(&nameBuf); - 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; - WCHAR *wMsgPtr; - char *msg; - char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; - Tcl_DString ds; - Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - - length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM - | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) &wMsgPtr, - 0, NULL); - if (length == 0) { - char *msgPtr; - - length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM - | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr, - 0, NULL); - if (length > 0) { - wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR)); - MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr, - length + 1); - LocalFree(msgPtr); - } - } - if (length == 0) { - if (error == ERROR_CALL_NOT_IMPLEMENTED) { - msg = "function not supported under Win32s"; - } else { - sprintf(msgBuf, "unknown error: %d", error); - msg = msgBuf; - } - } else { - Tcl_Encoding encoding; - - encoding = Tcl_GetEncoding(NULL, "unicode"); - Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds); - Tcl_FreeEncoding(encoding); - LocalFree(wMsgPtr); - - msg = Tcl_DStringValue(&ds); - length = Tcl_DStringLength(&ds); - - /* - * Trim the trailing CR/LF from the system message. - */ - if (msg[length-1] == '\n') { - msg[--length] = 0; - } - if (msg[length-1] == '\r') { - msg[--length] = 0; - } - } - - sprintf(id, "%d", error); - Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL); - Tcl_AppendToObj(resultPtr, msg, length); - - if (length != 0) { - Tcl_DStringFree(&ds); - } -} - -/* - *---------------------------------------------------------------------- - * - * 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; -} - - -/* $History: tclwinreg.c $ - * - * ***************** Version 1 ***************** - * User: Dtashley Date: 1/02/01 Time: 12:27a - * Created in $/IjuScripter, IjuConsole/Source/Tcl Base - * Initial check-in. - */ - -/* End of TCLWINREG.C */ \ No newline at end of file +/* $Header$ */ +/* + * 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. + * + * RCS: @(#) $Id: tclwinreg.c,v 1.1.1.1 2001/06/13 04:50:03 dtashley 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; + +/* + * The following structures allow us to select between the Unicode and ASCII + * interfaces at run time based on whether Unicode APIs are available. The + * Unicode APIs are preferable because they will handle characters outside + * of the current code page. + */ + +typedef struct RegWinProcs { + int useWide; + + LONG (WINAPI *regConnectRegistryProc)(TCHAR *, HKEY, PHKEY); + LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *, + DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *); + LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *); + LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *); + LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD); + LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, + TCHAR *, DWORD *, FILETIME *); + LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, + DWORD *, BYTE *, DWORD *); + LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM, + HKEY *); + LONG (WINAPI *regQueryInfoKeyProc)(HKEY, TCHAR *, DWORD *, DWORD *, + DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, + FILETIME *); + LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *, + BYTE *, DWORD *); + LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD, + CONST BYTE*, DWORD); +} RegWinProcs; + +static RegWinProcs *regWinProcs; + +static RegWinProcs asciiProcs = { + 0, + + (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryA, + (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, + DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, + DWORD *)) RegCreateKeyExA, + (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA, + (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA, + (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA, + (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, + TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA, + (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, + DWORD *, BYTE *, DWORD *)) RegEnumValueA, + (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, + HKEY *)) RegOpenKeyExA, + (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *, + DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, + FILETIME *)) RegQueryInfoKeyA, + (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, + BYTE *, DWORD *)) RegQueryValueExA, + (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, + CONST BYTE*, DWORD)) RegSetValueExA, +}; + +static RegWinProcs unicodeProcs = { + 1, + + (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryW, + (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, + DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, + DWORD *)) RegCreateKeyExW, + (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW, + (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW, + (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW, + (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, + TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW, + (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, + DWORD *, BYTE *, DWORD *)) RegEnumValueW, + (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, + HKEY *)) RegOpenKeyExW, + (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *, + DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, + FILETIME *)) RegQueryInfoKeyW, + (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, + BYTE *, DWORD *)) RegQueryValueExW, + (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, + CONST BYTE*, DWORD)) RegSetValueExW, +}; + + +/* + * 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, TCHAR * 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; + } + + /* + * Determine if the unicode interfaces are available and select the + * appropriate registry function table. + */ + + if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { + regWinProcs = &unicodeProcs; + } else { + regWinProcs = &asciiProcs; + } + + 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; + Tcl_DString buf; + + /* + * 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. + */ + + tail = Tcl_WinUtfToTChar(tail, -1, &buf); + result = RecursiveDeleteKey(subkey, tail); + Tcl_DStringFree(&buf); + + 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; + Tcl_DString ds; + + /* + * 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); + Tcl_WinUtfToTChar(valueName, length, &ds); + result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + if (result != ERROR_SUCCESS) { + Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"", + Tcl_GetString(valueNameObj), "\" from key \"", + Tcl_GetString(keyNameObj), "\": ", 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, *name; + Tcl_Obj *resultPtr; + int result = TCL_OK; + Tcl_DString ds; + + /* + * 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_GetString(patternObj); + } 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; (*regWinProcs->regEnumKeyProc)(key, index, buffer, + MAX_PATH+1) == ERROR_SUCCESS; index++) { + Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &ds); + name = Tcl_DStringValue(&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; + } + } + + 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; + Tcl_DString ds; + char *valueName; + int length; + + /* + * 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); + + valueName = Tcl_GetStringFromObj(valueNameObj, &length); + valueName = Tcl_WinUtfToTChar(valueName, length, &ds); + result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type, + NULL, NULL); + Tcl_DStringFree(&ds); + RegCloseKey(key); + + if (result != ERROR_SUCCESS) { + Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"", + Tcl_GetString(valueNameObj), "\" from key \"", + Tcl_GetString(keyNameObj), "\": ", 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, buf; + int nameLen; + + /* + * 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 of Dstrings changes. + * + * This allows short values to be read from the registy in one call. + * Longer values need a second call with an expanded DString. + */ + + Tcl_DStringInit(&data); + length = TCL_DSTRING_STATIC_SIZE - 1; + Tcl_DStringSetLength(&data, length); + + resultPtr = Tcl_GetObjResult(interp); + + valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen); + valueName = Tcl_WinUtfToTChar(valueName, nameLen, &buf); + + result = (*regWinProcs->regQueryValueExProc)(key, valueName, 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 *= 2; + Tcl_DStringSetLength(&data, length); + result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, + &type, (BYTE *) Tcl_DStringValue(&data), &length); + } + Tcl_DStringFree(&buf); + RegCloseKey(key); + if (result != ERROR_SUCCESS) { + Tcl_AppendStringsToObj(resultPtr, "unable to get value \"", + Tcl_GetString(valueNameObj), "\" from key \"", + Tcl_GetString(keyNameObj), "\": ", 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 *end = Tcl_DStringValue(&data) + length; + + /* + * 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 && ((regWinProcs->useWide) + ? *((Tcl_UniChar *)p) : *p) != 0) { + Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); + Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(Tcl_DStringValue(&buf), + Tcl_DStringLength(&buf))); + if (regWinProcs->useWide) { + while (*((Tcl_UniChar *)p)++ != 0) {} + } else { + while (*p++ != '\0') {} + } + Tcl_DStringFree(&buf); + } + } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { + Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf); + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buf), + Tcl_DStringLength(&buf)); + Tcl_DStringFree(&buf); + } else { + /* + * Save binary data as a byte array. + */ + + Tcl_SetByteArrayObj(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, maxSize, result; + Tcl_DString buffer, ds; + char *pattern, *name; + + /* + * 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 = (*regWinProcs->regQueryInfoKeyProc)(key, NULL, NULL, NULL, NULL, + NULL, NULL, &index, &maxSize, NULL, NULL, NULL); + if (result != ERROR_SUCCESS) { + Tcl_AppendStringsToObj(resultPtr, "unable to query key \"", + Tcl_GetString(keyNameObj), "\": ", NULL); + AppendSystemError(interp, result); + RegCloseKey(key); + result = TCL_ERROR; + goto done; + } + maxSize++; + + + Tcl_DStringInit(&buffer); + Tcl_DStringSetLength(&buffer, + (regWinProcs->useWide) ? maxSize*2 : maxSize); + 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 = maxSize; + while ((*regWinProcs->regEnumValueProc)(key, index, + Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) + == ERROR_SUCCESS) { + + if (regWinProcs->useWide) { + size *= 2; + } + + Tcl_WinTCharToUtf((TCHAR *) 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 = maxSize; + } + 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; + Tcl_DString buf; + + /* + * Attempt to open the root key on a remote host if necessary. + */ + + if (hostName) { + hostName = Tcl_WinUtfToTChar(hostName, -1, &buf); + result = (*regWinProcs->regConnectRegistryProc)(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. + */ + + keyName = Tcl_WinUtfToTChar(keyName, -1, &buf); + if (flags & REG_CREATE) { + DWORD create; + result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, "", + 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 = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, + mode, keyPtr); + } + } + Tcl_DStringFree(&buf); + + /* + * 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 in external + * encoding, not UTF. */ +{ + DWORD result, size, maxSize; + Tcl_DString subkey; + HKEY hKey; + + /* + * Do not allow NULL or empty key name. + */ + + if (!keyName || *keyName == '\0') { + return ERROR_BADKEY; + } + + result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0, + KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey); + if (result != ERROR_SUCCESS) { + return result; + } + result = (*regWinProcs->regQueryInfoKeyProc)(hKey, NULL, NULL, NULL, NULL, + &maxSize, NULL, NULL, NULL, NULL, NULL, NULL); + maxSize++; + if (result != ERROR_SUCCESS) { + return result; + } + + Tcl_DStringInit(&subkey); + Tcl_DStringSetLength(&subkey, + (regWinProcs->useWide) ? maxSize * 2 : maxSize); + + while (result == ERROR_SUCCESS) { + /* + * Always get index 0 because key deletion changes ordering. + */ + + size = maxSize; + result=(*regWinProcs->regEnumKeyExProc)(hKey, 0, + Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); + if (result == ERROR_NO_MORE_ITEMS) { + result = (*regWinProcs->regDeleteKeyProc)(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; + Tcl_DString nameBuf; + + 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); + valueName = Tcl_WinUtfToTChar(valueName, length, &nameBuf); + resultPtr = Tcl_GetObjResult(interp); + + if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { + DWORD value; + if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) { + RegCloseKey(key); + Tcl_DStringFree(&nameBuf); + return TCL_ERROR; + } + + value = ConvertDWORD(type, value); + result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, + (BYTE*) &value, sizeof(DWORD)); + } else if (type == REG_MULTI_SZ) { + Tcl_DString data, buf; + int 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++) { + Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1); + + /* + * Add a null character to separate this value from the next. + * We accomplish this by growing the string by one byte. Since the + * DString always tacks on an extra null byte, the new byte will + * already be set to null. + */ + + Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1); + } + + Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, + &buf); + result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, + (BYTE *) Tcl_DStringValue(&buf), + (DWORD) Tcl_DStringLength(&buf)); + Tcl_DStringFree(&data); + Tcl_DStringFree(&buf); + } else if (type == REG_SZ || type == REG_EXPAND_SZ) { + Tcl_DString buf; + char *data = Tcl_GetStringFromObj(dataObj, &length); + + data = Tcl_WinUtfToTChar(data, length, &buf); + + /* + * Include the null in the length, padding if needed for Unicode. + */ + + if (regWinProcs->useWide) { + Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); + } + length = Tcl_DStringLength(&buf) + 1; + + result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, + (BYTE*)data, length); + Tcl_DStringFree(&buf); + } else { + char *data; + + /* + * Store binary data in the registry. + */ + + data = Tcl_GetByteArrayFromObj(dataObj, &length); + result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, + (BYTE *)data, length); + } + Tcl_DStringFree(&nameBuf); + 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; + WCHAR *wMsgPtr; + char *msg; + char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; + Tcl_DString ds; + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + + length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM + | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) &wMsgPtr, + 0, NULL); + if (length == 0) { + char *msgPtr; + + length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM + | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr, + 0, NULL); + if (length > 0) { + wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR)); + MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr, + length + 1); + LocalFree(msgPtr); + } + } + if (length == 0) { + if (error == ERROR_CALL_NOT_IMPLEMENTED) { + msg = "function not supported under Win32s"; + } else { + sprintf(msgBuf, "unknown error: %d", error); + msg = msgBuf; + } + } else { + Tcl_Encoding encoding; + + encoding = Tcl_GetEncoding(NULL, "unicode"); + Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds); + Tcl_FreeEncoding(encoding); + LocalFree(wMsgPtr); + + msg = Tcl_DStringValue(&ds); + length = Tcl_DStringLength(&ds); + + /* + * Trim the trailing CR/LF from the system message. + */ + if (msg[length-1] == '\n') { + msg[--length] = 0; + } + if (msg[length-1] == '\r') { + msg[--length] = 0; + } + } + + sprintf(id, "%d", error); + Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL); + Tcl_AppendToObj(resultPtr, msg, length); + + if (length != 0) { + Tcl_DStringFree(&ds); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* End of tclwinreg.c */