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