diff options
Diffstat (limited to 'win/tclWinReg.c')
| -rw-r--r-- | win/tclWinReg.c | 1104 |
1 files changed, 712 insertions, 392 deletions
diff --git a/win/tclWinReg.c b/win/tclWinReg.c index ea947c2..327e4a3 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -1,106 +1,128 @@ -/* +/* * 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. + * 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.6 1998/09/14 18:40:20 stanton Exp $ + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include <tcl.h> +#undef STATIC_BUILD +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif +#include "tclInt.h" +#ifdef _MSC_VER +# pragma comment (lib, "advapi32.lib") +#endif #include <stdlib.h> -#define WIN32_LEAN_AND_MEAN -#include <windows.h> -#undef WIN32_LEAN_AND_MEAN +#ifndef UNICODE +# undef Tcl_WinTCharToUtf +# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) +# undef Tcl_WinUtfToTChar +# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) +#endif /* !UNICODE */ /* - * 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. + * Ensure that we can say which registry is being accessed. */ -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT +#ifndef KEY_WOW64_64KEY +# define KEY_WOW64_64KEY (0x0100) +#endif +#ifndef KEY_WOW64_32KEY +# define KEY_WOW64_32KEY (0x0200) +#endif /* - * VC++ has an alternate entry point called DllMain, so we need to rename - * our entry point. + * The maximum length of a sub-key name. */ -#ifdef DLL_BUILD -# if defined(_MSC_VER) -# define DllEntryPoint DllMain -# endif +#ifndef MAX_KEY_LENGTH +# define MAX_KEY_LENGTH 256 #endif /* + * 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))) - +#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. + * 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. + * The following tables contain the mapping from registry root names to the + * system predefined keys. */ -static char *rootKeyNames[] = { +static const char *const rootKeyNames[] = { "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT", - "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", NULL + "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", + "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL }; -static HKEY rootKeys[] = { +static const HKEY rootKeys[] = { HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA }; +static const char REGISTRY_ASSOC_KEY[] = "registry::command"; + /* - * The following table maps from registry types to strings. Note that - * the indices for this array are the same as the constants for the - * known registry types so we don't need a separate table to hold the - * mapping. + * 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", +static const char *const typeNames[] = { + "none", "sz", "expand_sz", "binary", "dword", "dword_big_endian", "link", "multi_sz", "resource_list", NULL }; static DWORD lastType = REG_RESOURCE_LIST; - /* * Declarations for functions defined in this file. */ static void AppendSystemError(Tcl_Interp *interp, DWORD error); +static int BroadcastValue(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static DWORD ConvertDWORD(DWORD type, DWORD value); -static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj); +static void DeleteCmd(ClientData clientData); +static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + REGSAM mode); static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj); + Tcl_Obj *valueNameObj, REGSAM mode); static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *patternObj); + Tcl_Obj *patternObj, REGSAM mode); static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj); + Tcl_Obj *valueNameObj, REGSAM mode); static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj); + Tcl_Obj *valueNameObj, REGSAM mode); static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *patternObj); + Tcl_Obj *patternObj, REGSAM mode); static int OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, REGSAM mode, int flags, HKEY *keyPtr); static DWORD OpenSubKey(char *hostName, HKEY rootKey, @@ -109,27 +131,27 @@ static DWORD OpenSubKey(char *hostName, HKEY rootKey, static int ParseKeyName(Tcl_Interp *interp, char *name, char **hostNamePtr, HKEY *rootKeyPtr, char **keyNamePtr); -static DWORD RecursiveDeleteKey(HKEY hStartKey, LPTSTR pKeyName); +static DWORD RecursiveDeleteKey(HKEY hStartKey, + const TCHAR * pKeyName, REGSAM mode); static int RegistryObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]); + 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); + Tcl_Obj *typeObj, REGSAM mode); -EXTERN int Registry_Init(Tcl_Interp *interp); +EXTERN int Registry_Init(Tcl_Interp *interp); +EXTERN int Registry_Unload(Tcl_Interp *interp, int flags); /* *---------------------------------------------------------------------- * - * DllEntryPoint -- + * Registry_Init -- * - * This wrapper function is used by Windows to invoke the - * initialization code for the DLL. If we are compiling - * with Visual C++, this routine will be renamed to DllMain. - * routine. + * This function initializes the registry command. * * Results: - * Returns TRUE; + * A standard Tcl result. * * Side effects: * None. @@ -137,41 +159,91 @@ EXTERN int Registry_Init(Tcl_Interp *interp); *---------------------------------------------------------------------- */ -#ifdef __WIN32__ -#ifdef DLL_BUILD -BOOL APIENTRY -DllEntryPoint( - HINSTANCE hInst, /* Library instance handle. */ - DWORD reason, /* Reason this function is being called. */ - LPVOID reserved) /* Not used. */ +int +Registry_Init( + Tcl_Interp *interp) { - return TRUE; + Tcl_Command cmd; + + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + return TCL_ERROR; + } + + cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, + interp, DeleteCmd); + Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); + return Tcl_PkgProvide(interp, "registry", "1.3.0"); } -#endif -#endif /* *---------------------------------------------------------------------- * - * Registry_Init -- + * Registry_Unload -- * - * This procedure initializes the registry command. + * This function removes the registry command. * * Results: * A standard Tcl result. * * Side effects: - * None. + * The registry command is deleted and the dll may be unloaded. * *---------------------------------------------------------------------- */ int -Registry_Init( - Tcl_Interp *interp) +Registry_Unload( + Tcl_Interp *interp, /* Interpreter for unloading */ + int flags) /* Flags passed by the unload system */ { - Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL); - return Tcl_PkgProvide(interp, "registry", "1.0"); + Tcl_Command cmd; + Tcl_Obj *objv[3]; + + /* + * Unregister the registry package. There is no Tcl_PkgForget() + */ + + objv[0] = Tcl_NewStringObj("package", -1); + objv[1] = Tcl_NewStringObj("forget", -1); + objv[2] = Tcl_NewStringObj("registry", -1); + Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL); + + /* + * Delete the originally registered command. + */ + + cmd = Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); + if (cmd != NULL) { + Tcl_DeleteCommandFromToken(interp, cmd); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteCmd -- + * + * Cleanup the interp command token so that unloading doesn't try to + * re-delete the command (which will crash). + * + * Results: + * None. + * + * Side effects: + * The unload command will not attempt to delete this command. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteCmd( + ClientData clientData) +{ + Tcl_Interp *interp = clientData; + + Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL); } /* @@ -195,84 +267,125 @@ RegistryObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj * CONST objv[]) /* Argument values. */ + 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 }; + int n = 1; + int index, argc; + REGSAM mode = 0; + const char *errString = NULL; + + static const char *const subcommands[] = { + "broadcast", "delete", "get", "keys", "set", "type", "values", NULL + }; + enum SubCmdIdx { + BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx + }; + static const char *const modes[] = { + "-32bit", "-64bit", NULL + }; if (objc < 2) { - Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?"); + wrongArgs: + Tcl_WrongNumArgs(interp, 1, objv, "?-32bit|-64bit? option ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index) - != TCL_OK) { + if (Tcl_GetString(objv[n])[0] == '-') { + if (Tcl_GetIndexFromObj(interp, objv[n++], modes, "mode", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case 0: /* -32bit */ + mode |= KEY_WOW64_32KEY; + break; + case 1: /* -64bit */ + mode |= KEY_WOW64_64KEY; + break; + } + if (objc < 3) { + goto wrongArgs; + } + } + + if (Tcl_GetIndexFromObj(interp, objv[n++], subcommands, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } + argc = (objc - n); switch (index) { - case 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. - */ + case BroadcastIdx: /* broadcast */ + if (argc == 1 || argc == 3) { + int res = BroadcastValue(interp, argc, objv + n); - 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); + if (res != TCL_BREAK) { + return res; } - 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 ?-timeout milliseconds?"; + break; + case DeleteIdx: /* delete */ + if (argc == 1) { + return DeleteKey(interp, objv[n], mode); + } else if (argc == 2) { + return DeleteValue(interp, objv[n], objv[n+1], mode); + } + errString = "keyName ?valueName?"; + break; + case GetIdx: /* get */ + if (argc == 2) { + return GetValue(interp, objv[n], objv[n+1], mode); + } + errString = "keyName valueName"; + break; + case KeysIdx: /* keys */ + if (argc == 1) { + return GetKeyNames(interp, objv[n], NULL, mode); + } else if (argc == 2) { + return GetKeyNames(interp, objv[n], objv[n+1], mode); + } + errString = "keyName ?pattern?"; + break; + case SetIdx: /* set */ + if (argc == 1) { + HKEY key; + + /* + * Create the key and then close it immediately. + */ + + mode |= KEY_ALL_ACCESS; + if (OpenKey(interp, objv[n], mode, 1, &key) != TCL_OK) { + return TCL_ERROR; } - errString = "keyName ?pattern?"; - break; + RegCloseKey(key); + return TCL_OK; + } else if (argc == 3) { + return SetValue(interp, objv[n], objv[n+1], objv[n+2], NULL, + mode); + } else if (argc == 4) { + return SetValue(interp, objv[n], objv[n+1], objv[n+2], objv[n+3], + mode); + } + errString = "keyName ?valueName data ?type??"; + break; + case TypeIdx: /* type */ + if (argc == 2) { + return GetType(interp, objv[n], objv[n+1], mode); + } + errString = "keyName valueName"; + break; + case ValuesIdx: /* values */ + if (argc == 1) { + return GetValueNames(interp, objv[n], NULL, mode); + } else if (argc == 2) { + return GetValueNames(interp, objv[n], objv[n+1], mode); + } + errString = "keyName ?pattern?"; + break; } - Tcl_WrongNumArgs(interp, 2, objv, errString); + Tcl_WrongNumArgs(interp, (mode ? 3 : 2), objv, errString); return TCL_ERROR; } @@ -295,13 +408,16 @@ RegistryObjCmd( static int DeleteKey( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *keyNameObj) /* Name of key to delete. */ + Tcl_Obj *keyNameObj, /* Name of key to delete. */ + REGSAM mode) /* Mode flags to pass. */ { char *tail, *buffer, *hostName, *keyName; + const TCHAR *nativeTail; HKEY rootKey, subkey; DWORD result; int length; - Tcl_Obj *resultPtr; + Tcl_DString buf; + REGSAM saveMode = mode; /* * Find the parent of the key being deleted and open it. @@ -311,15 +427,16 @@ DeleteKey( buffer = ckalloc(length + 1); strcpy(buffer, keyName); - if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName) - != TCL_OK) { + 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); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("bad key: cannot delete root keys", -1)); + Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL); ckfree(buffer); return TCL_ERROR; } @@ -332,27 +449,30 @@ DeleteKey( keyName = NULL; } - result = OpenSubKey(hostName, rootKey, keyName, - KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey); + mode |= KEY_ENUMERATE_SUB_KEYS | DELETE; + result = OpenSubKey(hostName, rootKey, keyName, mode, 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; } + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to delete key: ", -1)); + AppendSystemError(interp, result); + return TCL_ERROR; } /* * Now we recursively delete the key and everything below it. */ - result = RecursiveDeleteKey(subkey, tail); + nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf); + result = RecursiveDeleteKey(subkey, nativeTail, saveMode); + Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { - Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to delete key: ", -1)); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -384,30 +504,32 @@ static int DeleteValue( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj) /* Name of value to delete. */ + Tcl_Obj *valueNameObj, /* Name of value to delete. */ + REGSAM mode) /* Mode flags to pass. */ { 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) { + mode |= KEY_SET_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } - resultPtr = Tcl_GetObjResult(interp); valueName = Tcl_GetStringFromObj(valueNameObj, &length); - result = RegDeleteValue(key, valueName); + Tcl_WinUtfToTChar(valueName, length, &ds); + result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"", - Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"", - Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to delete value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -422,13 +544,13 @@ DeleteValue( * * 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. + * 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. + * Returns the list of subkeys in the result object of the interpreter, + * or an error message on failure. * * Side effects: * None. @@ -440,46 +562,74 @@ static int GetKeyNames( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Key to enumerate. */ - Tcl_Obj *patternObj) /* Optional match pattern. */ + Tcl_Obj *patternObj, /* Optional match pattern. */ + REGSAM mode) /* Mode flags to pass. */ { - HKEY key; - DWORD index; - char buffer[MAX_PATH+1], *pattern; - Tcl_Obj *resultPtr; - int result = TCL_OK; + const char *pattern; /* Pattern being matched against subkeys */ + HKEY key; /* Handle to the key being examined */ + TCHAR buffer[MAX_KEY_LENGTH]; + /* Buffer to hold the subkey name */ + DWORD bufSize; /* Size of the buffer */ + DWORD index; /* Position of the current subkey */ + char *name; /* Subkey name */ + Tcl_Obj *resultPtr; /* List of subkeys being accumulated */ + int result = TCL_OK; /* Return value from this command */ + Tcl_DString ds; /* Buffer to translate subkey name to UTF-8 */ + + if (patternObj) { + pattern = Tcl_GetString(patternObj); + } else { + pattern = NULL; + } /* * Attempt to open the key for enumeration. */ - if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key) - != TCL_OK) { + mode |= KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } - if (patternObj) { - pattern = Tcl_GetStringFromObj(patternObj, NULL); - } else { - pattern = NULL; - } - /* - * Enumerate over the subkeys until we get an error, indicating the - * end of the list. + * Enumerate the subkeys. */ - resultPtr = Tcl_GetObjResult(interp); - for (index = 0; RegEnumKey(key, index, buffer, MAX_PATH+1) - == ERROR_SUCCESS; index++) { - if (pattern && !Tcl_StringMatch(buffer, pattern)) { + resultPtr = Tcl_NewObj(); + for (index = 0;; ++index) { + bufSize = MAX_KEY_LENGTH; + result = RegEnumKeyEx(key, index, buffer, &bufSize, + NULL, NULL, NULL, NULL); + if (result != ERROR_SUCCESS) { + if (result == ERROR_NO_MORE_ITEMS) { + result = TCL_OK; + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to enumerate subkeys of \"%s\": ", + Tcl_GetString(keyNameObj))); + AppendSystemError(interp, result); + result = TCL_ERROR; + } + break; + } + Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds); + name = Tcl_DStringValue(&ds); + if (pattern && !Tcl_StringMatch(name, pattern)) { + Tcl_DStringFree(&ds); continue; } result = Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(buffer, -1)); + Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); if (result != TCL_OK) { break; } } + if (result == TCL_OK) { + Tcl_SetObjResult(interp, resultPtr); + } else { + Tcl_DecrRefCount(resultPtr); /* BUGFIX: Don't leak on failure. */ + } RegCloseKey(key); return result; @@ -490,8 +640,8 @@ GetKeyNames( * * GetType -- * - * This function gets the type of a given registry value and - * places it in the interpreter result. + * This function gets the type of a given registry value and places it in + * the interpreter result. * * Results: * Returns a normal Tcl result. @@ -506,19 +656,22 @@ static int GetType( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj) /* Name of value to get. */ + Tcl_Obj *valueNameObj, /* Name of value to get. */ + REGSAM mode) /* Mode flags to pass. */ { HKEY key; - Tcl_Obj *resultPtr; - DWORD result; - DWORD type; - + DWORD result, type; + Tcl_DString ds; + const char *valueName; + const TCHAR *nativeValue; + int length; + /* * Attempt to open the key for reading. */ - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) - != TCL_OK) { + mode |= KEY_QUERY_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } @@ -526,29 +679,30 @@ GetType( * Get the type of the value. */ - resultPtr = Tcl_GetObjResult(interp); - - result = RegQueryValueEx(key, Tcl_GetStringFromObj(valueNameObj, NULL), - NULL, &type, NULL, NULL); + valueName = Tcl_GetStringFromObj(valueNameObj, &length); + nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds); + result = RegQueryValueEx(key, nativeValue, NULL, &type, + NULL, NULL); + Tcl_DStringFree(&ds); RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"", - Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"", - Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get type of value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); return TCL_ERROR; } /* - * Set the type into the result. Watch out for unknown types. - * If we don't know about the type, just use the numeric value. + * 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); + if (type > lastType) { + Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type)); } else { - Tcl_SetStringObj(resultPtr, typeNames[type], -1); + Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1)); } return TCL_OK; } @@ -558,9 +712,8 @@ GetType( * * GetValue -- * - * This function gets the contents of a registry value and places - * a list containing the data and the type in the interpreter - * result. + * 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. @@ -575,85 +728,112 @@ static int GetValue( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj) /* Name of value to get. */ + Tcl_Obj *valueNameObj, /* Name of value to get. */ + REGSAM mode) /* Mode flags to pass. */ { HKEY key; - char *valueName; + const char *valueName; + const TCHAR *nativeValue; DWORD result, length, type; - Tcl_Obj *resultPtr; - Tcl_DString data; + Tcl_DString data, buf; + int nameLen; /* * Attempt to open the key for reading. */ - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) - != TCL_OK) { + mode |= KEY_QUERY_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } /* - * Initialize a Dstring to maximum statically allocated size - * we could get one more byte by avoiding Tcl_DStringSetLength() - * and just setting length to TCL_DSTRING_STATIC_SIZE, but this - * should be safer if the implementation Dstrings changes. + * 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); - Tcl_DStringSetLength(&data, length = TCL_DSTRING_STATIC_SIZE - 1); - - resultPtr = Tcl_GetObjResult(interp); - - valueName = Tcl_GetStringFromObj(valueNameObj, NULL); - result = RegQueryValueEx(key, valueName, NULL, &type, - (LPBYTE) Tcl_DStringValue(&data), &length); - if (result == ERROR_MORE_DATA) { - Tcl_DStringSetLength(&data, length); - result = RegQueryValueEx(key, valueName, NULL, &type, - (LPBYTE) Tcl_DStringValue(&data), &length); + Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1); + length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1; + + valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen); + nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf); + + result = RegQueryValueEx(key, nativeValue, NULL, &type, + (BYTE *) Tcl_DStringValue(&data), &length); + while (result == ERROR_MORE_DATA) { + /* + * The Windows docs say that in this error case, we just need to + * expand our buffer and request more data. Required for + * HKEY_PERFORMANCE_DATA + */ + + length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR)); + Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR)); + result = RegQueryValueEx(key, nativeValue, + NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); } + Tcl_DStringFree(&buf); RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to get value \"", - Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"", - Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); Tcl_DStringFree(&data); return TCL_ERROR; } /* - * If the data is a 32-bit quantity, store it as an integer object. If it - * is a multi-string, store it as a list of strings. For null-terminated - * strings, append up the to first null. Otherwise, store it as a binary + * 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)))); + Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type, + *((DWORD *) Tcl_DStringValue(&data))))); } else if (type == REG_MULTI_SZ) { char *p = Tcl_DStringValue(&data); - char *lastChar = Tcl_DStringValue(&data) + Tcl_DStringLength(&data); + char *end = Tcl_DStringValue(&data) + length; + Tcl_Obj *resultPtr = Tcl_NewObj(); /* * Multistrings are stored as an array of null-terminated strings, - * terminated by two null characters. Also do a bounds check in - * case we get bogus data. + * terminated by two null characters. Also do a bounds check in case + * we get bogus data. */ - while (p < lastChar && *p != '\0') { + while ((p < end) && *((Tcl_UniChar *) p) != 0) { + Tcl_UniChar *up; + + Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(p, -1)); - while (*p++ != '\0') {} + Tcl_NewStringObj(Tcl_DStringValue(&buf), + Tcl_DStringLength(&buf))); + up = (Tcl_UniChar *) p; + + while (*up++ != 0) {/* empty body */} + p = (char *) up; + Tcl_DStringFree(&buf); } + Tcl_SetObjResult(interp, resultPtr); } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), -1); + Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf); + Tcl_DStringResult(interp, &buf); } else { - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), length); + /* + * Save binary data as a byte array. + */ + + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( + (BYTE *) Tcl_DStringValue(&data), (int) length)); } Tcl_DStringFree(&data); return result; @@ -664,9 +844,9 @@ GetValue( * * 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. + * 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 @@ -682,75 +862,65 @@ static int GetValueNames( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Key to enumerate. */ - Tcl_Obj *patternObj) /* Optional match pattern. */ + Tcl_Obj *patternObj, /* Optional match pattern. */ + REGSAM mode) /* Mode flags to pass. */ { HKEY key; Tcl_Obj *resultPtr; DWORD index, size, result; - Tcl_DString buffer; - char *pattern; + Tcl_DString buffer, ds; + const char *pattern, *name; /* * Attempt to open the key for enumeration. */ - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) - != TCL_OK) { + mode |= KEY_QUERY_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } - resultPtr = Tcl_GetObjResult(interp); - - /* - * Query the key to determine the appropriate buffer size to hold the - * largest value name plus the terminating null. - */ - - result = RegQueryInfoKey(key, NULL, NULL, NULL, NULL, NULL, NULL, &index, - &size, NULL, NULL, NULL); - if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to query key \"", - Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL); - AppendSystemError(interp, result); - RegCloseKey(key); - result = TCL_ERROR; - goto done; - } - size++; - - + resultPtr = Tcl_NewObj(); Tcl_DStringInit(&buffer); - Tcl_DStringSetLength(&buffer, size); + Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); index = 0; result = TCL_OK; if (patternObj) { - pattern = Tcl_GetStringFromObj(patternObj, NULL); + 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. + * indicating the end of the list. Note that we need to reset size after + * each iteration because RegEnumValue smashes the old value. */ - while (RegEnumValue(key, index, Tcl_DStringValue(&buffer), &size, NULL, - NULL, NULL, NULL) == ERROR_SUCCESS) { - if (!pattern || Tcl_StringMatch(Tcl_DStringValue(&buffer), pattern)) { + size = MAX_KEY_LENGTH; + while (RegEnumValue(key,index, (TCHAR *)Tcl_DStringValue(&buffer), + &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { + size *= sizeof(TCHAR); + + Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, + &ds); + name = Tcl_DStringValue(&ds); + if (!pattern || Tcl_StringMatch(name, pattern)) { result = Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(Tcl_DStringValue(&buffer), size)); + Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); if (result != TCL_OK) { + Tcl_DStringFree(&ds); break; } } + Tcl_DStringFree(&ds); + index++; - size = Tcl_DStringLength(&buffer); + size = MAX_KEY_LENGTH; } + Tcl_SetObjResult(interp, resultPtr); Tcl_DStringFree(&buffer); - - done: RegCloseKey(key); return result; } @@ -760,12 +930,11 @@ GetValueNames( * * OpenKey -- * - * This function opens the specified key. This function is a - * simple wrapper around ParseKeyName and OpenSubKey. + * 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. + * Returns the opened key in the keyPtr argument and a Tcl result code. * * Side effects: * None. @@ -794,8 +963,8 @@ OpenKey( 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); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to open key: ", -1)); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -812,12 +981,12 @@ OpenKey( * * OpenSubKey -- * - * This function opens a given subkey of a root key on the - * specified host. + * 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. + * Returns the opened key in the keyPtr and a Windows error code as the + * return value. * * Side effects: * None. @@ -835,30 +1004,46 @@ OpenSubKey( HKEY *keyPtr) /* Returned HKEY. */ { DWORD result; + Tcl_DString buf; /* * Attempt to open the root key on a remote host if necessary. */ if (hostName) { - result = RegConnectRegistry(hostName, rootKey, &rootKey); + hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf); + result = RegConnectRegistry((TCHAR *)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. + * Now open the specified key with the requested permissions. Note that + * this key must be closed by the caller. */ + keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); if (flags & REG_CREATE) { DWORD create; - result = RegCreateKeyEx(rootKey, keyName, 0, "", + + result = RegCreateKeyEx(rootKey, (TCHAR *)keyName, 0, NULL, REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); + } else if (rootKey == HKEY_PERFORMANCE_DATA) { + /* + * Here we fudge it for this special root key. See MSDN for more info + * on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it. + */ + + *keyPtr = HKEY_PERFORMANCE_DATA; + result = ERROR_SUCCESS; } else { - result = RegOpenKeyEx(rootKey, keyName, 0, mode, keyPtr); + result = RegOpenKeyEx(rootKey, (TCHAR *)keyName, 0, mode, + keyPtr); } + Tcl_DStringFree(&buf); /* * Be sure to close the root key since we are done with it now. @@ -867,7 +1052,7 @@ OpenSubKey( if (hostName) { RegCloseKey(rootKey); } - return result; + return result; } /* @@ -875,15 +1060,12 @@ OpenSubKey( * * ParseKeyName -- * - * This function parses a key name into the host, root, and subkey - * parts. + * 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. - * + * 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. @@ -901,7 +1083,7 @@ ParseKeyName( { char *rootName; int result, index; - Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp); + Tcl_Obj *rootObj; /* * Split the key into host and root portions. @@ -922,8 +1104,9 @@ ParseKeyName( rootName = name; } if (!rootName) { - Tcl_AppendStringsToObj(resultPtr, "bad key \"", name, - "\": must start with a valid root", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad key \"%s\": must start with a valid root", name)); + Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL); return TCL_ERROR; } @@ -959,9 +1142,9 @@ ParseKeyName( * * 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. + * 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. @@ -975,48 +1158,69 @@ ParseKeyName( static DWORD RecursiveDeleteKey( HKEY startKey, /* Parent of key to be deleted. */ - char *keyName) /* Name of key to be deleted. */ + const TCHAR *keyName, /* Name of key to be deleted in external + * encoding, not UTF. */ + REGSAM mode) /* Mode flags to pass. */ { - DWORD result, subKeyLength; + DWORD result, size; Tcl_DString subkey; HKEY hKey; + REGSAM saveMode = mode; + static int checkExProc = 0; + static FARPROC regDeleteKeyExProc = NULL; /* * Do not allow NULL or empty key name. */ - if (!keyName || lstrlen(keyName) == '\0') { + if (!keyName || *keyName == '\0') { return ERROR_BADKEY; } - result = RegOpenKeyEx(startKey, keyName, 0, - KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey); - if (result != ERROR_SUCCESS) { - return result; - } - result = RegQueryInfoKey(hKey, NULL, NULL, NULL, NULL, &subKeyLength, - NULL, NULL, NULL, NULL, NULL, NULL); - subKeyLength++; + mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE; + result = RegOpenKeyEx(startKey, keyName, 0, mode, &hKey); if (result != ERROR_SUCCESS) { return result; } Tcl_DStringInit(&subkey); - Tcl_DStringSetLength(&subkey, subKeyLength); + Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + mode = saveMode; while (result == ERROR_SUCCESS) { /* * Always get index 0 because key deletion changes ordering. */ - subKeyLength = Tcl_DStringLength(&subkey); - result=RegEnumKeyEx(hKey, 0, Tcl_DStringValue(&subkey), &subKeyLength, - NULL, NULL, NULL, NULL); + size = MAX_KEY_LENGTH; + result = RegEnumKeyEx(hKey, 0, (TCHAR *)Tcl_DStringValue(&subkey), + &size, NULL, NULL, NULL, NULL); if (result == ERROR_NO_MORE_ITEMS) { - result = RegDeleteKey(startKey, keyName); + /* + * RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we + * can't compile with it in. We need to check for it at runtime + * and use it if we find it. + */ + + if (mode && !checkExProc) { + HINSTANCE dllH; + + checkExProc = 1; + dllH = LoadLibrary(TEXT("advapi32.dll")); + if (dllH) { + regDeleteKeyExProc = (FARPROC) + GetProcAddress(dllH, "RegDeleteKeyExW"); + } + } + if (mode && regDeleteKeyExProc) { + result = regDeleteKeyExProc(startKey, keyName, mode, 0); + } else { + result = RegDeleteKey(startKey, keyName); + } break; } else if (result == ERROR_SUCCESS) { - result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey)); + result = RecursiveDeleteKey(hKey, + (const TCHAR *) Tcl_DStringValue(&subkey), mode); } } Tcl_DStringFree(&subkey); @@ -1029,9 +1233,9 @@ RecursiveDeleteKey( * * 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. + * 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. @@ -1048,85 +1252,115 @@ SetValue( 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. */ + Tcl_Obj *typeObj, /* Type of data to be written. */ + REGSAM mode) /* Mode flags to pass. */ { - DWORD type, result; + int type, length; + DWORD result; HKEY key; - int length; - char *valueName; - Tcl_Obj *resultPtr; + const char *valueName; + 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) { + 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) { + mode |= KEY_ALL_ACCESS; + if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) { return TCL_ERROR; } valueName = Tcl_GetStringFromObj(valueNameObj, &length); - resultPtr = Tcl_GetObjResult(interp); + valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { - DWORD value; - if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) { + int value; + + if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) { RegCloseKey(key); + Tcl_DStringFree(&nameBuf); return TCL_ERROR; } - value = ConvertDWORD(type, value); - result = RegSetValueEx(key, valueName, 0, type, (BYTE*) &value, - sizeof(DWORD)); + value = ConvertDWORD((DWORD) type, (DWORD) value); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { - Tcl_DString data; + Tcl_DString data, buf; int objc, i; Tcl_Obj **objv; - char *element; 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. + * Append the elements as null terminated strings. Note that we must + * not assume the length of the string in case there are embedded + * nulls, which aren't allowed in REG_MULTI_SZ values. */ Tcl_DStringInit(&data); for (i = 0; i < objc; i++) { - element = Tcl_GetStringFromObj(objv[i], NULL); - Tcl_DStringAppend(&data, element, -1); - Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1); + const char *bytes = Tcl_GetStringFromObj(objv[i], &length); + + Tcl_DStringAppend(&data, bytes, length); + + /* + * Add a null character to separate this value from the next. + */ + + Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */ } - result = RegSetValueEx(key, valueName, 0, type, - (LPBYTE) Tcl_DStringValue(&data), - (DWORD) (Tcl_DStringLength(&data)+1)); + + Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, + &buf); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), + (DWORD) Tcl_DStringLength(&buf)); Tcl_DStringFree(&data); - } else { - char *data = Tcl_GetStringFromObj(dataObj, &length); + Tcl_DStringFree(&buf); + } else if (type == REG_SZ || type == REG_EXPAND_SZ) { + Tcl_DString buf; + const char *data = Tcl_GetStringFromObj(dataObj, &length); + + data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* - * Include the null in the length if we are storing a null terminated - * string. Note that we also need to call strlen to find the first - * null so we don't pass bad data to the registry. + * Include the null in the length, padding if needed for Unicode. */ - if (type == REG_SZ || type == REG_EXPAND_SZ) { - length = strlen(data) + 1; - } + Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); + length = Tcl_DStringLength(&buf) + 1; - result = RegSetValueEx(key, valueName, 0, type, (LPBYTE)data, length); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, (BYTE *) data, (DWORD) length); + Tcl_DStringFree(&buf); + } else { + BYTE *data; + + /* + * Store binary data in the registry. + */ + + data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, data, (DWORD) length); } + + Tcl_DStringFree(&nameBuf); RegCloseKey(key); + if (result != ERROR_SUCCESS) { - Tcl_AppendToObj(resultPtr, "unable to set value: ", -1); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to set value: ", -1)); AppendSystemError(interp, result); return TCL_ERROR; } @@ -1136,10 +1370,71 @@ SetValue( /* *---------------------------------------------------------------------- * + * BroadcastValue -- + * + * This function broadcasts a WM_SETTINGCHANGE message to indicate to + * other programs that we have changed the contents of a registry value. + * + * Results: + * Returns a normal Tcl result. + * + * Side effects: + * Will cause other programs to reload their system settings. + * + *---------------------------------------------------------------------- + */ + +static int +BroadcastValue( + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ +{ + LRESULT result; + DWORD_PTR sendResult; + UINT timeout = 3000; + int len; + const char *str; + Tcl_Obj *objPtr; + + if (objc == 3) { + str = Tcl_GetStringFromObj(objv[1], &len); + if ((len < 2) || (*str != '-') + || strncmp(str, "-timeout", (size_t) len)) { + return TCL_BREAK; + } + if (Tcl_GetIntFromObj(interp, objv[2], (int *) &timeout) != TCL_OK) { + return TCL_ERROR; + } + } + + str = Tcl_GetStringFromObj(objv[0], &len); + if (len == 0) { + str = NULL; + } + + /* + * Use the ignore the result. + */ + + result = SendMessageTimeoutA(HWND_BROADCAST, WM_SETTINGCHANGE, + (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult); + + objPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result)); + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult)); + Tcl_SetObjResult(interp, objPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * AppendSystemError -- * - * This routine formats a Windows system error message and places - * it into the interpreter result. + * This routine formats a Windows system error message and places it into + * the interpreter result. * * Results: * None. @@ -1156,36 +1451,52 @@ AppendSystemError( DWORD error) /* Result code from error. */ { int length; - char *msgbuf, id[10]; + TCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; + const char *msg; + char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; + Tcl_DString ds; Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - sprintf(id, "%d", error); + if (Tcl_IsShared(resultPtr)) { + resultPtr = Tcl_DuplicateObj(resultPtr); + } length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR)&msgbuf, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (TCHAR *) tMsgPtrPtr, 0, NULL); if (length == 0) { - if (error == ERROR_CALL_NOT_IMPLEMENTED) { - msgbuf = "function not supported under Win32s"; - } else { - msgbuf = id; - } + sprintf(msgBuf, "unknown error: %ld", error); + msg = msgBuf; } else { + char *msgPtr; + + Tcl_WinTCharToUtf(tMsgPtr, -1, &ds); + LocalFree(tMsgPtr); + + msgPtr = Tcl_DStringValue(&ds); + length = Tcl_DStringLength(&ds); + /* * Trim the trailing CR/LF from the system message. */ - if (msgbuf[length-1] == '\n') { - msgbuf[--length] = 0; + + if (msgPtr[length-1] == '\n') { + --length; } - if (msgbuf[length-1] == '\r') { - msgbuf[--length] = 0; + if (msgPtr[length-1] == '\r') { + --length; } + msgPtr[length] = 0; + msg = msgPtr; } - Tcl_SetErrorCode(interp, "WINDOWS", id, msgbuf, (char *) NULL); - Tcl_AppendToObj(resultPtr, msgbuf, -1); + + sprintf(id, "%ld", error); + Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL); + Tcl_AppendToObj(resultPtr, msg, length); + Tcl_SetObjResult(interp, resultPtr); if (length != 0) { - LocalFree(msgbuf); + Tcl_DStringFree(&ds); } } @@ -1194,8 +1505,8 @@ AppendSystemError( * * ConvertDWORD -- * - * This function determines whether a DWORD needs to be byte - * swapped, and returns the appropriately swapped value. + * This function determines whether a DWORD needs to be byte swapped, and + * returns the appropriately swapped value. * * Results: * Returns a converted DWORD. @@ -1211,13 +1522,22 @@ ConvertDWORD( DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */ DWORD value) /* The value to be converted. */ { - DWORD order = 1; + const 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; + localType = (*((const char *) &order) == 1) + ? REG_DWORD : REG_DWORD_BIG_ENDIAN; + return (type != localType) ? (DWORD) SWAPLONG(value) : value; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |