--- /dev/null
+/*
+ * 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
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
OSDN Git Service
