#include <tcl.h>
#include <stdlib.h>
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
#ifdef DLL_BUILD
# if defined(_MSC_VER)
# define DllEntryPoint DllMain
# endif
#endif
#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
#define REG_CREATE 1
static char *rootKeyNames[] = {
"HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
"HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", NULL
};
static HKEY rootKeys[] = {
HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
};
static char *typeNames[] = {
"none", "sz", "expand_sz", "binary", "dword",
"dword_big_endian", "link", "multi_sz", "resource_list", NULL
};
static DWORD lastType = REG_RESOURCE_LIST;
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, LPTSTR 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);
#ifdef __WIN32__
#ifdef DLL_BUILD
BOOL APIENTRY
DllEntryPoint(
HINSTANCE hInst,
DWORD reason,
LPVOID reserved)
{
return TRUE;
}
#endif
#endif
int
Registry_Init(
Tcl_Interp *interp)
{
Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);
return Tcl_PkgProvide(interp, "registry", "1.0");
}
static int
RegistryObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj * CONST objv[])
{
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:
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:
if (objc == 4) {
return GetValue(interp, objv[2], objv[3]);
}
errString = "keyName valueName";
break;
case KeysIdx:
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:
if (objc == 3) {
HKEY key;
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:
if (objc == 4) {
return GetType(interp, objv[2], objv[3]);
}
errString = "keyName valueName";
break;
case ValuesIdx:
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;
}
static int
DeleteKey(
Tcl_Interp *interp,
Tcl_Obj *keyNameObj)
{
char *tail, *buffer, *hostName, *keyName;
HKEY rootKey, subkey;
DWORD result;
int length;
Tcl_Obj *resultPtr;
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;
}
}
result = RecursiveDeleteKey(subkey, tail);
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;
}
static int
DeleteValue(
Tcl_Interp *interp,
Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj)
{
HKEY key;
char *valueName;
int length;
DWORD result;
Tcl_Obj *resultPtr;
if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key)
!= TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_GetObjResult(interp);
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
result = RegDeleteValue(key, valueName);
if (result != ERROR_SUCCESS) {
Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"",
Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
result = TCL_OK;
}
RegCloseKey(key);
return result;
}
static int
GetKeyNames(
Tcl_Interp *interp,
Tcl_Obj *keyNameObj,
Tcl_Obj *patternObj)
{
HKEY key;
DWORD index;
char buffer[MAX_PATH+1], *pattern;
Tcl_Obj *resultPtr;
int result = TCL_OK;
if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key)
!= TCL_OK) {
return TCL_ERROR;
}
if (patternObj) {
pattern = Tcl_GetStringFromObj(patternObj, NULL);
} else {
pattern = NULL;
}
resultPtr = Tcl_GetObjResult(interp);
for (index = 0; RegEnumKey(key, index, buffer, MAX_PATH+1)
== ERROR_SUCCESS; index++) {
if (pattern && !Tcl_StringMatch(buffer, pattern)) {
continue;
}
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(buffer, -1));
if (result != TCL_OK) {
break;
}
}
RegCloseKey(key);
return result;
}
static int
GetType(
Tcl_Interp *interp,
Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj)
{
HKEY key;
Tcl_Obj *resultPtr;
DWORD result;
DWORD type;
if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
!= TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_GetObjResult(interp);
result = RegQueryValueEx(key, Tcl_GetStringFromObj(valueNameObj, NULL),
NULL, &type, NULL, NULL);
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);
AppendSystemError(interp, result);
return TCL_ERROR;
}
if (type > lastType || type < 0) {
Tcl_SetIntObj(resultPtr, type);
} else {
Tcl_SetStringObj(resultPtr, typeNames[type], -1);
}
return TCL_OK;
}
static int
GetValue(
Tcl_Interp *interp,
Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj)
{
HKEY key;
char *valueName;
DWORD result, length, type;
Tcl_Obj *resultPtr;
Tcl_DString data;
if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
!= TCL_OK) {
return TCL_ERROR;
}
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);
}
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_AppendStringsToObj(resultPtr, "unable to get value \"",
Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
AppendSystemError(interp, result);
Tcl_DStringFree(&data);
return TCL_ERROR;
}
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 *lastChar = Tcl_DStringValue(&data) + Tcl_DStringLength(&data);
while (p < lastChar && *p != '\0') {
Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(p, -1));
while (*p++ != '\0') {}
}
} else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), -1);
} else {
Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), length);
}
Tcl_DStringFree(&data);
return result;
}
static int
GetValueNames(
Tcl_Interp *interp,
Tcl_Obj *keyNameObj,
Tcl_Obj *patternObj)
{
HKEY key;
Tcl_Obj *resultPtr;
DWORD index, size, result;
Tcl_DString buffer;
char *pattern;
if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
!= TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_GetObjResult(interp);
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++;
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, size);
index = 0;
result = TCL_OK;
if (patternObj) {
pattern = Tcl_GetStringFromObj(patternObj, NULL);
} else {
pattern = NULL;
}
while (RegEnumValue(key, index, Tcl_DStringValue(&buffer), &size, NULL,
NULL, NULL, NULL) == ERROR_SUCCESS) {
if (!pattern || Tcl_StringMatch(Tcl_DStringValue(&buffer), pattern)) {
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(Tcl_DStringValue(&buffer), size));
if (result != TCL_OK) {
break;
}
}
index++;
size = Tcl_DStringLength(&buffer);
}
Tcl_DStringFree(&buffer);
done:
RegCloseKey(key);
return result;
}
static int
OpenKey(
Tcl_Interp *interp,
Tcl_Obj *keyNameObj,
REGSAM mode,
int flags,
HKEY *keyPtr)
{
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;
}
static DWORD
OpenSubKey(
char *hostName,
HKEY rootKey,
char *keyName,
REGSAM mode,
int flags,
HKEY *keyPtr)
{
DWORD result;
if (hostName) {
result = RegConnectRegistry(hostName, rootKey, &rootKey);
if (result != ERROR_SUCCESS) {
return result;
}
}
if (flags & REG_CREATE) {
DWORD create;
result = RegCreateKeyEx(rootKey, keyName, 0, "",
REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
} else {
result = RegOpenKeyEx(rootKey, keyName, 0, mode, keyPtr);
}
if (hostName) {
RegCloseKey(rootKey);
}
return result;
}
static int
ParseKeyName(
Tcl_Interp *interp,
char *name,
char **hostNamePtr,
HKEY *rootKeyPtr,
char **keyNamePtr)
{
char *rootName;
int result, index;
Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp);
*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;
}
for (*keyNamePtr = rootName; **keyNamePtr != '\0'; (*keyNamePtr)++) {
if (**keyNamePtr == '\\') {
**keyNamePtr = '\0';
(*keyNamePtr)++;
break;
}
}
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;
}
static DWORD
RecursiveDeleteKey(
HKEY startKey,
char *keyName)
{
DWORD result, subKeyLength;
Tcl_DString subkey;
HKEY hKey;
if (!keyName || lstrlen(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++;
if (result != ERROR_SUCCESS) {
return result;
}
Tcl_DStringInit(&subkey);
Tcl_DStringSetLength(&subkey, subKeyLength);
while (result == ERROR_SUCCESS) {
subKeyLength = Tcl_DStringLength(&subkey);
result=RegEnumKeyEx(hKey, 0, Tcl_DStringValue(&subkey), &subKeyLength,
NULL, NULL, NULL, NULL);
if (result == ERROR_NO_MORE_ITEMS) {
result = RegDeleteKey(startKey, keyName);
break;
} else if (result == ERROR_SUCCESS) {
result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey));
}
}
Tcl_DStringFree(&subkey);
RegCloseKey(hKey);
return result;
}
static int
SetValue(
Tcl_Interp *interp,
Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj,
Tcl_Obj *dataObj,
Tcl_Obj *typeObj)
{
DWORD type, result;
HKEY key;
int length;
char *valueName;
Tcl_Obj *resultPtr;
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);
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);
return TCL_ERROR;
}
value = ConvertDWORD(type, value);
result = RegSetValueEx(key, valueName, 0, type, (BYTE*) &value,
sizeof(DWORD));
} else if (type == REG_MULTI_SZ) {
Tcl_DString data;
int objc, i;
Tcl_Obj **objv;
char *element;
if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
RegCloseKey(key);
return TCL_ERROR;
}
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);
}
result = RegSetValueEx(key, valueName, 0, type,
(LPBYTE) Tcl_DStringValue(&data),
(DWORD) (Tcl_DStringLength(&data)+1));
Tcl_DStringFree(&data);
} else {
char *data = Tcl_GetStringFromObj(dataObj, &length);
if (type == REG_SZ || type == REG_EXPAND_SZ) {
length = strlen(data) + 1;
}
result = RegSetValueEx(key, valueName, 0, type, (LPBYTE)data, length);
}
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_AppendToObj(resultPtr, "unable to set value: ", -1);
AppendSystemError(interp, result);
return TCL_ERROR;
}
return TCL_OK;
}
static void
AppendSystemError(
Tcl_Interp *interp,
DWORD error)
{
int length;
char *msgbuf, id[10];
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
sprintf(id, "%d", error);
length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR)&msgbuf,
0, NULL);
if (length == 0) {
if (error == ERROR_CALL_NOT_IMPLEMENTED) {
msgbuf = "function not supported under Win32s";
} else {
msgbuf = id;
}
} else {
if (msgbuf[length-1] == '\n') {
msgbuf[--length] = 0;
}
if (msgbuf[length-1] == '\r') {
msgbuf[--length] = 0;
}
}
Tcl_SetErrorCode(interp, "WINDOWS", id, msgbuf, (char *) NULL);
Tcl_AppendToObj(resultPtr, msgbuf, -1);
if (length != 0) {
LocalFree(msgbuf);
}
}
static DWORD
ConvertDWORD(
DWORD type,
DWORD value)
{
DWORD order = 1;
DWORD localType;
localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
return (type != localType) ? SWAPLONG(value) : value;
}