riscv
/
OpenFPGA
mirror of https://github.com/lnis-uofu/OpenFPGA.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
OpenFPGA/libs/EXTERNAL/tcl8.6.12/win/tclWinReg.c

1578 lines
40 KiB
C
Raw Normal View History

adding Tcl interface to vpr
2022-06-07 11:15:20 -05:00
/*
* tclWinReg.c --
*
* This file contains the implementation of the "registry" Tcl built-in
* command. This command is built as a dynamically loadable extension in
* a separate DLL.
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
#include "tclInt.h"
#ifdef _MSC_VER
# pragma comment (lib, "advapi32.lib")
#endif
#include <stdlib.h>
/*
* Ensure that we can say which registry is being accessed.
*/
#ifndef KEY_WOW64_64KEY
# define KEY_WOW64_64KEY (0x0100)
#endif
#ifndef KEY_WOW64_32KEY
# define KEY_WOW64_32KEY (0x0200)
#endif
/*
* The maximum length of a sub-key name.
*/
#ifndef MAX_KEY_LENGTH
# define MAX_KEY_LENGTH 256
#endif
/*
* The following macros convert between different endian ints.
*/
#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
/*
* The following flag is used in OpenKeys to indicate that the specified key
* should be created if it doesn't currently exist.
*/
#define REG_CREATE 1
/*
* The following tables contain the mapping from registry root names to the
* system predefined keys.
*/
static const char *const rootKeyNames[] = {
"HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
"HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG",
"HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL
};
static const HKEY rootKeys[] = {
HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
};
static const char REGISTRY_ASSOC_KEY[] = "registry::command";
/*
* The following table maps from registry types to strings. Note that the
* indices for this array are the same as the constants for the known registry
* types so we don't need a separate table to hold the mapping.
*/
static const char *const typeNames[] = {
"none", "sz", "expand_sz", "binary", "dword",
"dword_big_endian", "link", "multi_sz", "resource_list", NULL
};
static DWORD lastType = REG_RESOURCE_LIST;
/*
* Declarations for functions defined in this file.
*/
static void AppendSystemError(Tcl_Interp *interp, DWORD error);
static int BroadcastValue(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static DWORD ConvertDWORD(DWORD type, DWORD value);
static void DeleteCmd(void *clientData);
static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
REGSAM mode);
static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj, REGSAM mode);
static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *patternObj, REGSAM mode);
static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj, REGSAM mode);
static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj, REGSAM mode);
static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *patternObj, REGSAM mode);
static int OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
REGSAM mode, int flags, HKEY *keyPtr);
static DWORD OpenSubKey(char *hostName, HKEY rootKey,
char *keyName, REGSAM mode, int flags,
HKEY *keyPtr);
static int ParseKeyName(Tcl_Interp *interp, char *name,
char **hostNamePtr, HKEY *rootKeyPtr,
char **keyNamePtr);
static DWORD RecursiveDeleteKey(HKEY hStartKey,
const WCHAR * pKeyName, REGSAM mode);
static int RegistryObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
Tcl_Obj *typeObj, REGSAM mode);
#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7)
# if TCL_UTF_MAX > 3
# define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c)
# define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c)
# else
# define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString
# define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString
# endif
#endif
static unsigned char *
getByteArrayFromObj(
Tcl_Obj *objPtr,
size_t *lengthPtr
) {
int length;
unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length);
#if TCL_MAJOR_VERSION > 8
if (sizeof(TCL_HASH_TYPE) > sizeof(int)) {
/* 64-bit and TIP #494 situation: */
*lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1;
} else
#endif
/* 32-bit or without TIP #494 */
*lengthPtr = (size_t) (unsigned) length;
return result;
}
#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int Registry_Init(Tcl_Interp *interp);
DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags);
#ifdef __cplusplus
}
#endif
/*
*----------------------------------------------------------------------
*
* Registry_Init --
*
* This function initializes the registry command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Registry_Init(
Tcl_Interp *interp)
{
Tcl_Command cmd;
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
return Tcl_PkgProvideEx(interp, "registry", "1.3.5", NULL);
}
/*
*----------------------------------------------------------------------
*
* Registry_Unload --
*
* This function removes the registry command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The registry command is deleted and the dll may be unloaded.
*
*----------------------------------------------------------------------
*/
int
Registry_Unload(
Tcl_Interp *interp, /* Interpreter for unloading */
int flags) /* Flags passed by the unload system */
{
Tcl_Command cmd;
Tcl_Obj *objv[3];
(void)flags;
/*
* Unregister the registry package. There is no Tcl_PkgForget()
*/
objv[0] = Tcl_NewStringObj("package", -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_Command)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(
void *clientData)
{
Tcl_Interp *interp = (Tcl_Interp *)clientData;
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL);
}
/*
*----------------------------------------------------------------------
*
* RegistryObjCmd --
*
* This function implements the Tcl "registry" command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
RegistryObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
int n = 1;
int index, argc;
REGSAM mode = 0;
const char *errString = NULL;
static const char *const subcommands[] = {
"broadcast", "delete", "get", "keys", "set", "type", "values", NULL
};
enum SubCmdIdx {
BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx
};
static const char *const modes[] = {
"-32bit", "-64bit", NULL
};
(void)dummy;
if (objc < 2) {
wrongArgs:
Tcl_WrongNumArgs(interp, 1, objv, "?-32bit|-64bit? option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetString(objv[n])[0] == '-') {
if (Tcl_GetIndexFromObj(interp, objv[n++], modes, "mode", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case 0: /* -32bit */
mode |= KEY_WOW64_32KEY;
break;
case 1: /* -64bit */
mode |= KEY_WOW64_64KEY;
break;
}
if (objc < 3) {
goto wrongArgs;
}
}
if (Tcl_GetIndexFromObj(interp, objv[n++], subcommands, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
argc = (objc - n);
switch (index) {
case BroadcastIdx: /* broadcast */
if (argc == 1 || argc == 3) {
int res = BroadcastValue(interp, argc, objv + n);
if (res != TCL_BREAK) {
return res;
}
}
errString = "keyName ?-timeout milliseconds?";
break;
case DeleteIdx: /* delete */
if (argc == 1) {
return DeleteKey(interp, objv[n], mode);
} else if (argc == 2) {
return DeleteValue(interp, objv[n], objv[n+1], mode);
}
errString = "keyName ?valueName?";
break;
case GetIdx: /* get */
if (argc == 2) {
return GetValue(interp, objv[n], objv[n+1], mode);
}
errString = "keyName valueName";
break;
case KeysIdx: /* keys */
if (argc == 1) {
return GetKeyNames(interp, objv[n], NULL, mode);
} else if (argc == 2) {
return GetKeyNames(interp, objv[n], objv[n+1], mode);
}
errString = "keyName ?pattern?";
break;
case SetIdx: /* set */
if (argc == 1) {
HKEY key;
/*
* Create the key and then close it immediately.
*/
mode |= KEY_ALL_ACCESS;
if (OpenKey(interp, objv[n], mode, 1, &key) != TCL_OK) {
return TCL_ERROR;
}
RegCloseKey(key);
return TCL_OK;
} else if (argc == 3) {
return SetValue(interp, objv[n], objv[n+1], objv[n+2], NULL,
mode);
} else if (argc == 4) {
return SetValue(interp, objv[n], objv[n+1], objv[n+2], objv[n+3],
mode);
}
errString = "keyName ?valueName data ?type??";
break;
case TypeIdx: /* type */
if (argc == 2) {
return GetType(interp, objv[n], objv[n+1], mode);
}
errString = "keyName valueName";
break;
case ValuesIdx: /* values */
if (argc == 1) {
return GetValueNames(interp, objv[n], NULL, mode);
} else if (argc == 2) {
return GetValueNames(interp, objv[n], objv[n+1], mode);
}
errString = "keyName ?pattern?";
break;
}
Tcl_WrongNumArgs(interp, (mode ? 3 : 2), objv, errString);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* DeleteKey --
*
* This function deletes a registry key.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
DeleteKey(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key to delete. */
REGSAM mode) /* Mode flags to pass. */
{
char *tail, *buffer, *hostName, *keyName;
const WCHAR *nativeTail;
HKEY rootKey, subkey;
DWORD result;
Tcl_DString buf;
REGSAM saveMode = mode;
/*
* Find the parent of the key being deleted and open it.
*/
keyName = Tcl_GetString(keyNameObj);
buffer = (char *)Tcl_Alloc(keyNameObj->length + 1);
strcpy(buffer, keyName);
if (ParseKeyName(interp, buffer, &hostName, &rootKey,
&keyName) != TCL_OK) {
Tcl_Free(buffer);
return TCL_ERROR;
}
if (*keyName == '\0') {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("bad key: cannot delete root keys", -1));
Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL);
Tcl_Free(buffer);
return TCL_ERROR;
}
tail = strrchr(keyName, '\\');
if (tail) {
*tail++ = '\0';
} else {
tail = keyName;
keyName = NULL;
}
mode |= KEY_ENUMERATE_SUB_KEYS | DELETE;
result = OpenSubKey(hostName, rootKey, keyName, mode, 0, &subkey);
if (result != ERROR_SUCCESS) {
Tcl_Free(buffer);
if (result == ERROR_FILE_NOT_FOUND) {
return TCL_OK;
}
Tcl_SetObjResult(interp,
Tcl_NewStringObj("unable to delete key: ", -1));
AppendSystemError(interp, result);
return TCL_ERROR;
}
/*
* Now we recursively delete the key and everything below it.
*/
Tcl_DStringInit(&buf);
nativeTail = Tcl_UtfToWCharDString(tail, -1, &buf);
result = RecursiveDeleteKey(subkey, nativeTail, saveMode);
Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("unable to delete key: ", -1));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
result = TCL_OK;
}
RegCloseKey(subkey);
Tcl_Free(buffer);
return result;
}
/*
*----------------------------------------------------------------------
*
* DeleteValue --
*
* This function deletes a value from a registry key.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
DeleteValue(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key. */
Tcl_Obj *valueNameObj, /* Name of value to delete. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
char *valueName;
DWORD result;
Tcl_DString ds;
/*
* Attempt to open the key for deletion.
*/
mode |= KEY_SET_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetString(valueNameObj);
Tcl_DStringInit(&ds);
Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds);
result = RegDeleteValueW(key, (const WCHAR *)Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to delete value \"%s\" from key \"%s\": ",
Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
result = TCL_OK;
}
RegCloseKey(key);
return result;
}
/*
*----------------------------------------------------------------------
*
* GetKeyNames --
*
* This function enumerates the subkeys of a given key. If the optional
* pattern is supplied, then only keys that match the pattern will be
* returned.
*
* Results:
* Returns the list of subkeys in the result object of the interpreter,
* or an error message on failure.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
GetKeyNames(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to enumerate. */
Tcl_Obj *patternObj, /* Optional match pattern. */
REGSAM mode) /* Mode flags to pass. */
{
const char *pattern; /* Pattern being matched against subkeys */
HKEY key; /* Handle to the key being examined */
WCHAR buffer[MAX_KEY_LENGTH];
/* Buffer to hold the subkey name */
DWORD bufSize; /* Size of the buffer */
DWORD index; /* Position of the current subkey */
char *name; /* Subkey name */
Tcl_Obj *resultPtr; /* List of subkeys being accumulated */
int result = TCL_OK; /* Return value from this command */
Tcl_DString ds; /* Buffer to translate subkey name to UTF-8 */
if (patternObj) {
pattern = Tcl_GetString(patternObj);
} else {
pattern = NULL;
}
/*
* Attempt to open the key for enumeration.
*/
mode |= KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
/*
* Enumerate the subkeys.
*/
resultPtr = Tcl_NewObj();
for (index = 0;; ++index) {
bufSize = MAX_KEY_LENGTH;
result = RegEnumKeyExW(key, index, buffer, &bufSize,
NULL, NULL, NULL, NULL);
if (result != ERROR_SUCCESS) {
if (result == ERROR_NO_MORE_ITEMS) {
result = TCL_OK;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to enumerate subkeys of \"%s\": ",
Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
}
break;
}
Tcl_DStringInit(&ds);
name = Tcl_WCharToUtfDString(buffer, bufSize, &ds);
if (pattern && !Tcl_StringMatch(name, pattern)) {
Tcl_DStringFree(&ds);
continue;
}
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
if (result != TCL_OK) {
break;
}
}
if (result == TCL_OK) {
Tcl_SetObjResult(interp, resultPtr);
} else {
Tcl_DecrRefCount(resultPtr); /* BUGFIX: Don't leak on failure. */
}
RegCloseKey(key);
return result;
}
/*
*----------------------------------------------------------------------
*
* GetType --
*
* This function gets the type of a given registry value and places it in
* the interpreter result.
*
* Results:
* Returns a normal Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
GetType(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key. */
Tcl_Obj *valueNameObj, /* Name of value to get. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
DWORD result, type;
Tcl_DString ds;
const char *valueName;
const WCHAR *nativeValue;
/*
* Attempt to open the key for reading.
*/
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
/*
* Get the type of the value.
*/
valueName = Tcl_GetString(valueNameObj);
Tcl_DStringInit(&ds);
nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds);
result = RegQueryValueExW(key, nativeValue, NULL, &type,
NULL, NULL);
Tcl_DStringFree(&ds);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to get type of value \"%s\" from key \"%s\": ",
Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
return TCL_ERROR;
}
/*
* Set the type into the result. Watch out for unknown types. If we don't
* know about the type, just use the numeric value.
*/
if (type > lastType) {
Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type));
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -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. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
const char *valueName;
const WCHAR *nativeValue;
DWORD result, length, type;
Tcl_DString data, buf;
/*
* Attempt to open the key for reading.
*/
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
/*
* Initialize a Dstring to maximum statically allocated size we could get
* one more byte by avoiding Tcl_DStringSetLength() and just setting
* length to TCL_DSTRING_STATIC_SIZE, but this should be safer if the
* implementation of Dstrings changes.
*
* This allows short values to be read from the registy in one call.
* Longer values need a second call with an expanded DString.
*/
Tcl_DStringInit(&data);
Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
length = TCL_DSTRING_STATIC_SIZE/sizeof(WCHAR) - 1;
valueName = Tcl_GetString(valueNameObj);
Tcl_DStringInit(&buf);
nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &buf);
result = RegQueryValueExW(key, nativeValue, NULL, &type,
(BYTE *) Tcl_DStringValue(&data), &length);
while (result == ERROR_MORE_DATA) {
/*
* The Windows docs say that in this error case, we just need to
* expand our buffer and request more data. Required for
* HKEY_PERFORMANCE_DATA
*/
length = Tcl_DStringLength(&data) * (2 / sizeof(WCHAR));
Tcl_DStringSetLength(&data, (int) length * sizeof(WCHAR));
result = RegQueryValueExW(key, nativeValue,
NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
}
Tcl_DStringFree(&buf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to get value \"%s\" from key \"%s\": ",
Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
Tcl_DStringFree(&data);
return TCL_ERROR;
}
/*
* If the data is a 32-bit quantity, store it as an integer object. If it
* is a multi-string, store it as a list of strings. For null-terminated
* strings, append up the to first null. Otherwise, store it as a binary
* string.
*/
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type,
*((DWORD *) Tcl_DStringValue(&data)))));
} else if (type == REG_MULTI_SZ) {
char *p = Tcl_DStringValue(&data);
char *end = Tcl_DStringValue(&data) + length;
Tcl_Obj *resultPtr = Tcl_NewObj();
/*
* Multistrings are stored as an array of null-terminated strings,
* terminated by two null characters. Also do a bounds check in case
* we get bogus data.
*/
while ((p < end) && *((WCHAR *) p) != 0) {
WCHAR *wp = (WCHAR *) p;
Tcl_DStringInit(&buf);
Tcl_WCharToUtfDString(wp, wcslen(wp), &buf);
Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf)));
while (*wp++ != 0) {/* empty body */}
p = (char *) wp;
Tcl_DStringFree(&buf);
}
Tcl_SetObjResult(interp, resultPtr);
} else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
WCHAR *wp = (WCHAR *) Tcl_DStringValue(&data);
Tcl_DStringInit(&buf);
Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&data), wcslen(wp), &buf);
Tcl_DStringResult(interp, &buf);
} else {
/*
* Save binary data as a byte array.
*/
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
(BYTE *) Tcl_DStringValue(&data), (int) 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. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
Tcl_Obj *resultPtr;
DWORD index, size, result;
Tcl_DString buffer, ds;
const char *pattern, *name;
/*
* Attempt to open the key for enumeration.
*/
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewObj();
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(WCHAR)));
index = 0;
result = TCL_OK;
if (patternObj) {
pattern = Tcl_GetString(patternObj);
} else {
pattern = NULL;
}
/*
* Enumerate the values under the given subkey until we get an error,
* indicating the end of the list. Note that we need to reset size after
* each iteration because RegEnumValue smashes the old value.
*/
size = MAX_KEY_LENGTH;
while (RegEnumValueW(key,index, (WCHAR *)Tcl_DStringValue(&buffer),
&size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) {
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&buffer), size, &ds);
name = Tcl_DStringValue(&ds);
if (!pattern || Tcl_StringMatch(name, pattern)) {
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
if (result != TCL_OK) {
Tcl_DStringFree(&ds);
break;
}
}
Tcl_DStringFree(&ds);
index++;
size = MAX_KEY_LENGTH;
}
Tcl_SetObjResult(interp, resultPtr);
Tcl_DStringFree(&buffer);
RegCloseKey(key);
return result;
}
/*
*----------------------------------------------------------------------
*
* OpenKey --
*
* This function opens the specified key. This function is a simple
* wrapper around ParseKeyName and OpenSubKey.
*
* Results:
* Returns the opened key in the keyPtr argument and a Tcl result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
OpenKey(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to open. */
REGSAM mode, /* Access mode. */
int flags, /* 0 or REG_CREATE. */
HKEY *keyPtr) /* Returned HKEY. */
{
char *keyName, *buffer, *hostName;
HKEY rootKey;
DWORD result;
keyName = Tcl_GetString(keyNameObj);
buffer = (char *)Tcl_Alloc(keyNameObj->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_SetObjResult(interp,
Tcl_NewStringObj("unable to open key: ", -1));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
result = TCL_OK;
}
}
Tcl_Free(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) {
Tcl_DStringInit(&buf);
hostName = (char *) Tcl_UtfToWCharDString(hostName, -1, &buf);
result = RegConnectRegistryW((WCHAR *)hostName, rootKey,
&rootKey);
Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS) {
return result;
}
}
/*
* Now open the specified key with the requested permissions. Note that
* this key must be closed by the caller.
*/
if (keyName) {
Tcl_DStringInit(&buf);
keyName = (char *) Tcl_UtfToWCharDString(keyName, -1, &buf);
}
if (flags & REG_CREATE) {
DWORD create;
result = RegCreateKeyExW(rootKey, (WCHAR *)keyName, 0, NULL,
REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
} else if (rootKey == HKEY_PERFORMANCE_DATA) {
/*
* Here we fudge it for this special root key. See MSDN for more info
* on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it.
*/
*keyPtr = HKEY_PERFORMANCE_DATA;
result = ERROR_SUCCESS;
} else {
result = RegOpenKeyExW(rootKey, (WCHAR *)keyName, 0, mode,
keyPtr);
}
if (keyName) {
Tcl_DStringFree(&buf);
}
/*
* Be sure to close the root key since we are done with it now.
*/
if (hostName) {
RegCloseKey(rootKey);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* ParseKeyName --
*
* 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;
/*
* Split the key into host and root portions.
*/
*hostNamePtr = *keyNamePtr = rootName = NULL;
if (name[0] == '\\') {
if (name[1] == '\\') {
*hostNamePtr = name;
for (rootName = name+2; *rootName != '\0'; rootName++) {
if (*rootName == '\\') {
*rootName++ = '\0';
break;
}
}
}
} else {
rootName = name;
}
if (!rootName) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad key \"%s\": must start with a valid root", name));
Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL);
return TCL_ERROR;
}
/*
* Split the root into root and subkey portions.
*/
for (*keyNamePtr = rootName; **keyNamePtr != '\0'; (*keyNamePtr)++) {
if (**keyNamePtr == '\\') {
**keyNamePtr = '\0';
(*keyNamePtr)++;
break;
}
}
/*
* Look for a matching root name.
*/
rootObj = Tcl_NewStringObj(rootName, -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. */
const WCHAR *keyName, /* Name of key to be deleted in external
* encoding, not UTF. */
REGSAM mode) /* Mode flags to pass. */
{
DWORD result, size;
Tcl_DString subkey;
HKEY hKey;
REGSAM saveMode = mode;
static int checkExProc = 0;
static LONG (* regDeleteKeyExProc) (HKEY, LPCWSTR, REGSAM, DWORD) = (LONG (*) (HKEY, LPCWSTR, REGSAM, DWORD)) NULL;
/*
* Do not allow NULL or empty key name.
*/
if (!keyName || *keyName == '\0') {
return ERROR_BADKEY;
}
mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE;
result = RegOpenKeyExW(startKey, keyName, 0, mode, &hKey);
if (result != ERROR_SUCCESS) {
return result;
}
Tcl_DStringInit(&subkey);
Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(WCHAR)));
mode = saveMode;
while (result == ERROR_SUCCESS) {
/*
* Always get index 0 because key deletion changes ordering.
*/
size = MAX_KEY_LENGTH;
result = RegEnumKeyExW(hKey, 0, (WCHAR *)Tcl_DStringValue(&subkey),
&size, NULL, NULL, NULL, NULL);
if (result == ERROR_NO_MORE_ITEMS) {
/*
* RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we
* can't compile with it in. We need to check for it at runtime
* and use it if we find it.
*/
if (mode && !checkExProc) {
HMODULE handle;
checkExProc = 1;
handle = GetModuleHandleW(L"ADVAPI32");
regDeleteKeyExProc = (LONG (*) (HKEY, LPCWSTR, REGSAM, DWORD))
(void *)GetProcAddress(handle, "RegDeleteKeyExW");
}
if (mode && regDeleteKeyExProc) {
result = regDeleteKeyExProc(startKey, keyName, mode, 0);
} else {
result = RegDeleteKeyW(startKey, keyName);
}
break;
} else if (result == ERROR_SUCCESS) {
result = RecursiveDeleteKey(hKey,
(const WCHAR *) Tcl_DStringValue(&subkey), mode);
}
}
Tcl_DStringFree(&subkey);
RegCloseKey(hKey);
return result;
}
/*
*----------------------------------------------------------------------
*
* SetValue --
*
* This function sets the contents of a registry value. If the key or
* value does not exist, it will be created. If it does exist, then the
* data and type will be replaced.
*
* Results:
* Returns a normal Tcl result.
*
* Side effects:
* May create new keys or values.
*
*----------------------------------------------------------------------
*/
static int
SetValue(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key. */
Tcl_Obj *valueNameObj, /* Name of value to set. */
Tcl_Obj *dataObj, /* Data to be written. */
Tcl_Obj *typeObj, /* Type of data to be written. */
REGSAM mode) /* Mode flags to pass. */
{
int type;
DWORD result;
HKEY key;
const char *valueName;
Tcl_DString nameBuf;
if (typeObj == NULL) {
type = REG_SZ;
} else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type",
0, (int *) &type) != TCL_OK) {
if (Tcl_GetIntFromObj(NULL, typeObj, (int *) &type) != TCL_OK) {
return TCL_ERROR;
}
Tcl_ResetResult(interp);
}
mode |= KEY_ALL_ACCESS;
if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetString(valueNameObj);
Tcl_DStringInit(&nameBuf);
valueName = (char *) Tcl_UtfToWCharDString(valueName, valueNameObj->length, &nameBuf);
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
int value;
if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) {
RegCloseKey(key);
Tcl_DStringFree(&nameBuf);
return TCL_ERROR;
}
value = ConvertDWORD((DWORD) type, (DWORD) value);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, (BYTE *) &value, sizeof(DWORD));
} else if (type == REG_MULTI_SZ) {
Tcl_DString data, buf;
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++) {
const char *bytes = Tcl_GetString(objv[i]);
Tcl_DStringAppend(&data, bytes, objv[i]->length);
/*
* Add a null character to separate this value from the next.
*/
Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */
}
Tcl_DStringInit(&buf);
Tcl_UtfToWCharDString(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
&buf);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
(DWORD) Tcl_DStringLength(&buf));
Tcl_DStringFree(&data);
Tcl_DStringFree(&buf);
} else if (type == REG_SZ || type == REG_EXPAND_SZ) {
Tcl_DString buf;
const char *data = Tcl_GetString(dataObj);
Tcl_DStringInit(&buf);
data = (char *) Tcl_UtfToWCharDString(data, dataObj->length, &buf);
/*
* Include the null in the length, padding if needed for WCHAR.
*/
Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1);
Tcl_DStringFree(&buf);
} else {
BYTE *data;
size_t bytelength;
/*
* Store binary data in the registry.
*/
data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, data, (DWORD) bytelength);
}
Tcl_DStringFree(&nameBuf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("unable to set value: ", -1));
AppendSystemError(interp, result);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* BroadcastValue --
*
* This function broadcasts a WM_SETTINGCHANGE message to indicate to
* other programs that we have changed the contents of a registry value.
*
* Results:
* Returns a normal Tcl result.
*
* Side effects:
* Will cause other programs to reload their system settings.
*
*----------------------------------------------------------------------
*/
static int
BroadcastValue(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
LRESULT result;
DWORD_PTR sendResult;
int timeout = 3000;
size_t len;
const char *str;
Tcl_Obj *objPtr;
WCHAR *wstr;
Tcl_DString ds;
if (objc == 3) {
str = Tcl_GetString(objv[1]);
len = objv[1]->length;
if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) {
return TCL_BREAK;
}
if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) {
return TCL_ERROR;
}
}
str = Tcl_GetString(objv[0]);
Tcl_DStringInit(&ds);
wstr = Tcl_UtfToWCharDString(str, objv[0]->length, &ds);
if (Tcl_DStringLength(&ds) == 0) {
wstr = NULL;
}
/*
* Use the ignore the result.
*/
result = SendMessageTimeoutW(HWND_BROADCAST, WM_SETTINGCHANGE,
(WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult);
Tcl_DStringFree(&ds);
objPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result));
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) sendResult));
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AppendSystemError --
*
* 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 *tMsgPtr, **tMsgPtrPtr = &tMsgPtr;
const char *msg;
char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
Tcl_DString ds;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
}
length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) tMsgPtrPtr,
0, NULL);
if (length == 0) {
sprintf(msgBuf, "unknown error: %ld", error);
msg = msgBuf;
} else {
char *msgPtr;
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(tMsgPtr, wcslen(tMsgPtr), &ds);
LocalFree(tMsgPtr);
msgPtr = Tcl_DStringValue(&ds);
length = Tcl_DStringLength(&ds);
/*
* Trim the trailing CR/LF from the system message.
*/
if (msgPtr[length-1] == '\n') {
--length;
}
if (msgPtr[length-1] == '\r') {
--length;
}
msgPtr[length] = 0;
msg = msgPtr;
}
sprintf(id, "%ld", error);
Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL);
Tcl_AppendToObj(resultPtr, msg, length);
Tcl_SetObjResult(interp, resultPtr);
if (length != 0) {
Tcl_DStringFree(&ds);
}
}
/*
*----------------------------------------------------------------------
*
* ConvertDWORD --
*
* 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. */
{
const DWORD order = 1;
DWORD localType;
/*
* Check to see if the low bit is in the first byte.
*/
localType = (*((const char *) &order) == 1)
? REG_DWORD : REG_DWORD_BIG_ENDIAN;
return (type != localType) ? (DWORD) SWAPLONG(value) : value;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/