/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinreg.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinreg.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 64 by dashley, Sun Oct 30 04:21:11 2016 UTC revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
 /* $Header$ */  
   
 /*  
  * 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.1.1.1 2001/06/13 04:50:03 dtashley Exp $  
  */  
   
 #include <tclPort.h>  
 #include <stdlib.h>  
   
 #define WIN32_LEAN_AND_MEAN  
 #include <windows.h>  
 #undef WIN32_LEAN_AND_MEAN  
   
 /*  
  * 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 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 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)(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 *)(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 *)(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 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, 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);  
   
 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.0");  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * 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;  
   
     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:                 /* delete */  
             if (objc == 3) {  
                 return DeleteKey(interp, objv[2]);  
             } else if (objc == 4) {  
                 return DeleteValue(interp, objv[2], objv[3]);  
             }  
             errString = "keyName ?valueName?";  
             break;  
         case GetIdx:                    /* get */  
             if (objc == 4) {  
                 return GetValue(interp, objv[2], objv[3]);  
             }  
             errString = "keyName valueName";  
             break;  
         case KeysIdx:                   /* keys */  
             if (objc == 3) {  
                 return GetKeyNames(interp, objv[2], NULL);  
             } else if (objc == 4) {  
                 return GetKeyNames(interp, objv[2], objv[3]);  
             }  
             errString = "keyName ?pattern?";  
             break;  
         case SetIdx:                    /* set */  
             if (objc == 3) {  
                 HKEY key;  
   
                 /*  
                  * Create the key and then close it immediately.  
                  */  
   
                 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:                   /* type */  
             if (objc == 4) {  
                 return GetType(interp, objv[2], objv[3]);  
             }  
             errString = "keyName valueName";  
             break;  
         case ValuesIdx:                 /* values */  
             if (objc == 3) {  
                 return GetValueNames(interp, objv[2], NULL);  
             } else if (objc == 4) {  
                 return GetValueNames(interp, objv[2], objv[3]);  
             }  
             errString = "keyName ?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. */  
 {  
     char *tail, *buffer, *hostName, *keyName;  
     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(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.  
      */  
   
     tail = Tcl_WinUtfToTChar(tail, -1, &buf);  
     result = RecursiveDeleteKey(subkey, tail);  
     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. */  
 {  
     HKEY key;  
     char *valueName;  
     int length;  
     DWORD result;  
     Tcl_Obj *resultPtr;  
     Tcl_DString ds;  
   
     /*  
      * Attempt to open the key for deletion.  
      */  
   
     if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key)  
             != TCL_OK) {  
         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. */  
 {  
     HKEY key;  
     DWORD index;  
     char buffer[MAX_PATH+1], *pattern, *name;  
     Tcl_Obj *resultPtr;  
     int result = TCL_OK;  
     Tcl_DString ds;  
   
     /*  
      * Attempt to open the key for enumeration.  
      */  
   
     if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key)  
             != TCL_OK) {  
         return TCL_ERROR;  
     }  
   
     if (patternObj) {  
         pattern = Tcl_GetString(patternObj);  
     } else {  
         pattern = NULL;  
     }  
   
     /*  
      * Enumerate over the subkeys until we get an error, indicating the  
      * end of the list.  
      */  
   
     resultPtr = Tcl_GetObjResult(interp);  
     for (index = 0; (*regWinProcs->regEnumKeyProc)(key, index, buffer,  
             MAX_PATH+1) == ERROR_SUCCESS; index++) {  
         Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &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;  
         }  
     }  
   
     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. */  
 {  
     HKEY key;  
     Tcl_Obj *resultPtr;  
     DWORD result;  
     DWORD type;  
     Tcl_DString ds;  
     char *valueName;  
     int length;  
   
     /*  
      * Attempt to open the key for reading.  
      */  
   
     if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)  
             != TCL_OK) {  
         return TCL_ERROR;  
     }  
   
     /*  
      * Get the type of the value.  
      */  
   
     resultPtr = Tcl_GetObjResult(interp);  
   
     valueName = Tcl_GetStringFromObj(valueNameObj, &length);  
     valueName = Tcl_WinUtfToTChar(valueName, length, &ds);  
     result = (*regWinProcs->regQueryValueExProc)(key, valueName, 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, 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. */  
 {  
     HKEY key;  
     char *valueName;  
     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, 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, length);  
   
     resultPtr = Tcl_GetObjResult(interp);  
   
     valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);  
     valueName = Tcl_WinUtfToTChar(valueName, nameLen, &buf);  
   
     result = (*regWinProcs->regQueryValueExProc)(key, valueName, 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, length);  
         result = (*regWinProcs->regQueryValueExProc)(key, valueName, 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, 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), 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. */  
 {  
     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, 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,  
             (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), 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(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 = 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 = Tcl_WinUtfToTChar(keyName, -1, &buf);  
     if (flags & REG_CREATE) {  
         DWORD create;  
         result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, "",  
                 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. */  
     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,  
             (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. */  
 {  
     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, 1, &key) != TCL_OK) {  
         return TCL_ERROR;  
     }  
   
     valueName = Tcl_GetStringFromObj(valueNameObj, &length);  
     valueName = 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 = 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, 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, 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;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * 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: %d", 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, "%d", 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;  
 }  
   
   
 /* $History: tclwinreg.c $  
  *  
  * *****************  Version 1  *****************  
  * User: Dtashley     Date: 1/02/01    Time: 12:27a  
  * Created in $/IjuScripter, IjuConsole/Source/Tcl Base  
  * Initial check-in.  
  */  
   
 /* End of TCLWINREG.C */  
1    /* $Header$ */
2    /*
3     * tclWinReg.c --
4     *
5     *      This file contains the implementation of the "registry" Tcl
6     *      built-in command.  This command is built as a dynamically
7     *      loadable extension in a separate DLL.
8     *
9     * Copyright (c) 1997 by Sun Microsystems, Inc.
10     * Copyright (c) 1998-1999 by Scriptics Corporation.
11     *
12     * See the file "license.terms" for information on usage and redistribution
13     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14     *
15     * RCS: @(#) $Id: tclwinreg.c,v 1.1.1.1 2001/06/13 04:50:03 dtashley Exp $
16     */
17    
18    #include <tclPort.h>
19    #include <stdlib.h>
20    
21    #define WIN32_LEAN_AND_MEAN
22    #include <windows.h>
23    #undef WIN32_LEAN_AND_MEAN
24    
25    /*
26     * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
27     * Registry_Init declaration is in the source file itself, which is only
28     * accessed when we are building a library.
29     */
30    
31    #undef TCL_STORAGE_CLASS
32    #define TCL_STORAGE_CLASS DLLEXPORT
33    
34    /*
35     * The following macros convert between different endian ints.
36     */
37    
38    #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
39    #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
40    
41    /*
42     * The following flag is used in OpenKeys to indicate that the specified
43     * key should be created if it doesn't currently exist.
44     */
45    
46    #define REG_CREATE 1
47    
48    /*
49     * The following tables contain the mapping from registry root names
50     * to the system predefined keys.
51     */
52    
53    static char *rootKeyNames[] = {
54        "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
55        "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG",
56        "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL
57    };
58    
59    static HKEY rootKeys[] = {
60        HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
61        HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
62    };
63    
64    /*
65     * The following table maps from registry types to strings.  Note that
66     * the indices for this array are the same as the constants for the
67     * known registry types so we don't need a separate table to hold the
68     * mapping.
69     */
70    
71    static char *typeNames[] = {
72        "none", "sz", "expand_sz", "binary", "dword",
73        "dword_big_endian", "link", "multi_sz", "resource_list", NULL
74    };
75    
76    static DWORD lastType = REG_RESOURCE_LIST;
77    
78    /*
79     * The following structures allow us to select between the Unicode and ASCII
80     * interfaces at run time based on whether Unicode APIs are available.  The
81     * Unicode APIs are preferable because they will handle characters outside
82     * of the current code page.
83     */
84    
85    typedef struct RegWinProcs {
86        int useWide;
87    
88        LONG (WINAPI *regConnectRegistryProc)(TCHAR *, HKEY, PHKEY);
89        LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
90                DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
91        LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);
92        LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *);
93        LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD);
94        LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
95                TCHAR *, DWORD *, FILETIME *);
96        LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
97                DWORD *, BYTE *, DWORD *);
98        LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM,
99                HKEY *);
100        LONG (WINAPI *regQueryInfoKeyProc)(HKEY, TCHAR *, DWORD *, DWORD *,
101                DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
102                FILETIME *);
103        LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
104                BYTE *, DWORD *);
105        LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD,
106                CONST BYTE*, DWORD);
107    } RegWinProcs;
108    
109    static RegWinProcs *regWinProcs;
110    
111    static RegWinProcs asciiProcs = {
112        0,
113    
114        (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
115        (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
116                DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
117                DWORD *)) RegCreateKeyExA,
118        (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA,
119        (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA,
120        (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA,
121        (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
122                TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA,
123        (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
124                DWORD *, BYTE *, DWORD *)) RegEnumValueA,
125        (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
126                HKEY *)) RegOpenKeyExA,
127        (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *,
128                DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
129                FILETIME *)) RegQueryInfoKeyA,
130        (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
131                BYTE *, DWORD *)) RegQueryValueExA,
132        (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
133                CONST BYTE*, DWORD)) RegSetValueExA,
134    };
135    
136    static RegWinProcs unicodeProcs = {
137        1,
138    
139        (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
140        (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
141                DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
142                DWORD *)) RegCreateKeyExW,
143        (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW,
144        (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW,
145        (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW,
146        (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
147                TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW,
148        (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
149                DWORD *, BYTE *, DWORD *)) RegEnumValueW,
150        (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
151                HKEY *)) RegOpenKeyExW,
152        (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *,
153                DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
154                FILETIME *)) RegQueryInfoKeyW,
155        (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
156                BYTE *, DWORD *)) RegQueryValueExW,
157        (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
158                CONST BYTE*, DWORD)) RegSetValueExW,
159    };
160    
161    
162    /*
163     * Declarations for functions defined in this file.
164     */
165    
166    static void             AppendSystemError(Tcl_Interp *interp, DWORD error);
167    static DWORD            ConvertDWORD(DWORD type, DWORD value);
168    static int              DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);
169    static int              DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
170                                Tcl_Obj *valueNameObj);
171    static int              GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
172                                Tcl_Obj *patternObj);
173    static int              GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
174                                Tcl_Obj *valueNameObj);
175    static int              GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
176                                Tcl_Obj *valueNameObj);
177    static int              GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
178                                Tcl_Obj *patternObj);
179    static int              OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
180                                REGSAM mode, int flags, HKEY *keyPtr);
181    static DWORD            OpenSubKey(char *hostName, HKEY rootKey,
182                                char *keyName, REGSAM mode, int flags,
183                                HKEY *keyPtr);
184    static int              ParseKeyName(Tcl_Interp *interp, char *name,
185                                char **hostNamePtr, HKEY *rootKeyPtr,
186                                char **keyNamePtr);
187    static DWORD            RecursiveDeleteKey(HKEY hStartKey, TCHAR * pKeyName);
188    static int              RegistryObjCmd(ClientData clientData,
189                                Tcl_Interp *interp, int objc,
190                                Tcl_Obj * CONST objv[]);
191    static int              SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
192                                Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
193                                Tcl_Obj *typeObj);
194    
195    EXTERN int Registry_Init(Tcl_Interp *interp);
196    
197    /*
198     *----------------------------------------------------------------------
199     *
200     * Registry_Init --
201     *
202     *      This procedure initializes the registry command.
203     *
204     * Results:
205     *      A standard Tcl result.
206     *
207     * Side effects:
208     *      None.
209     *
210     *----------------------------------------------------------------------
211     */
212    
213    int
214    Registry_Init(
215        Tcl_Interp *interp)
216    {
217        if (!Tcl_InitStubs(interp, "8.0", 0)) {
218            return TCL_ERROR;
219        }
220    
221        /*
222         * Determine if the unicode interfaces are available and select the
223         * appropriate registry function table.
224         */
225    
226        if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
227            regWinProcs = &unicodeProcs;
228        } else {
229            regWinProcs = &asciiProcs;
230        }
231    
232        Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);
233        return Tcl_PkgProvide(interp, "registry", "1.0");
234    }
235    
236    /*
237     *----------------------------------------------------------------------
238     *
239     * RegistryObjCmd --
240     *
241     *      This function implements the Tcl "registry" command.
242     *
243     * Results:
244     *      A standard Tcl result.
245     *
246     * Side effects:
247     *      None.
248     *
249     *----------------------------------------------------------------------
250     */
251    
252    static int
253    RegistryObjCmd(
254        ClientData clientData,      /* Not used. */
255        Tcl_Interp *interp,         /* Current interpreter. */
256        int objc,                   /* Number of arguments. */
257        Tcl_Obj * CONST objv[])     /* Argument values. */
258    {
259        int index;
260        char *errString;
261    
262        static char *subcommands[] = { "delete", "get", "keys", "set", "type",
263                                       "values", (char *) NULL };
264        enum SubCmdIdx { DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx };
265    
266        if (objc < 2) {
267            Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?");
268            return TCL_ERROR;
269        }
270    
271        if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index)
272                != TCL_OK) {
273            return TCL_ERROR;
274        }
275    
276        switch (index) {
277            case DeleteIdx:                 /* delete */
278                if (objc == 3) {
279                    return DeleteKey(interp, objv[2]);
280                } else if (objc == 4) {
281                    return DeleteValue(interp, objv[2], objv[3]);
282                }
283                errString = "keyName ?valueName?";
284                break;
285            case GetIdx:                    /* get */
286                if (objc == 4) {
287                    return GetValue(interp, objv[2], objv[3]);
288                }
289                errString = "keyName valueName";
290                break;
291            case KeysIdx:                   /* keys */
292                if (objc == 3) {
293                    return GetKeyNames(interp, objv[2], NULL);
294                } else if (objc == 4) {
295                    return GetKeyNames(interp, objv[2], objv[3]);
296                }
297                errString = "keyName ?pattern?";
298                break;
299            case SetIdx:                    /* set */
300                if (objc == 3) {
301                    HKEY key;
302    
303                    /*
304                     * Create the key and then close it immediately.
305                     */
306    
307                    if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key)
308                            != TCL_OK) {
309                        return TCL_ERROR;
310                    }
311                    RegCloseKey(key);
312                    return TCL_OK;
313                } else if (objc == 5 || objc == 6) {
314                    Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
315                    return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
316                }
317                errString = "keyName ?valueName data ?type??";
318                break;
319            case TypeIdx:                   /* type */
320                if (objc == 4) {
321                    return GetType(interp, objv[2], objv[3]);
322                }
323                errString = "keyName valueName";
324                break;
325            case ValuesIdx:                 /* values */
326                if (objc == 3) {
327                    return GetValueNames(interp, objv[2], NULL);
328                } else if (objc == 4) {
329                    return GetValueNames(interp, objv[2], objv[3]);
330                }
331                errString = "keyName ?pattern?";
332                break;
333        }
334        Tcl_WrongNumArgs(interp, 2, objv, errString);
335        return TCL_ERROR;
336    }
337    
338    /*
339     *----------------------------------------------------------------------
340     *
341     * DeleteKey --
342     *
343     *      This function deletes a registry key.
344     *
345     * Results:
346     *      A standard Tcl result.
347     *
348     * Side effects:
349     *      None.
350     *
351     *----------------------------------------------------------------------
352     */
353    
354    static int
355    DeleteKey(
356        Tcl_Interp *interp,         /* Current interpreter. */
357        Tcl_Obj *keyNameObj)        /* Name of key to delete. */
358    {
359        char *tail, *buffer, *hostName, *keyName;
360        HKEY rootKey, subkey;
361        DWORD result;
362        int length;
363        Tcl_Obj *resultPtr;
364        Tcl_DString buf;
365    
366        /*
367         * Find the parent of the key being deleted and open it.
368         */
369    
370        keyName = Tcl_GetStringFromObj(keyNameObj, &length);
371        buffer = ckalloc(length + 1);
372        strcpy(buffer, keyName);
373    
374        if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName)
375                != TCL_OK) {
376            ckfree(buffer);
377            return TCL_ERROR;
378        }
379    
380        resultPtr = Tcl_GetObjResult(interp);
381        if (*keyName == '\0') {
382            Tcl_AppendToObj(resultPtr, "bad key: cannot delete root keys", -1);
383            ckfree(buffer);
384            return TCL_ERROR;
385        }
386    
387        tail = strrchr(keyName, '\\');
388        if (tail) {
389            *tail++ = '\0';
390        } else {
391            tail = keyName;
392            keyName = NULL;
393        }
394    
395        result = OpenSubKey(hostName, rootKey, keyName,
396                KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey);
397        if (result != ERROR_SUCCESS) {
398            ckfree(buffer);
399            if (result == ERROR_FILE_NOT_FOUND) {
400                return TCL_OK;
401            } else {
402                Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
403                AppendSystemError(interp, result);
404                return TCL_ERROR;
405            }
406        }
407    
408        /*
409         * Now we recursively delete the key and everything below it.
410         */
411    
412        tail = Tcl_WinUtfToTChar(tail, -1, &buf);
413        result = RecursiveDeleteKey(subkey, tail);
414        Tcl_DStringFree(&buf);
415    
416        if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
417            Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
418            AppendSystemError(interp, result);
419            result = TCL_ERROR;
420        } else {
421            result = TCL_OK;
422        }
423    
424        RegCloseKey(subkey);
425        ckfree(buffer);
426        return result;
427    }
428    
429    /*
430     *----------------------------------------------------------------------
431     *
432     * DeleteValue --
433     *
434     *      This function deletes a value from a registry key.
435     *
436     * Results:
437     *      A standard Tcl result.
438     *
439     * Side effects:
440     *      None.
441     *
442     *----------------------------------------------------------------------
443     */
444    
445    static int
446    DeleteValue(
447        Tcl_Interp *interp,         /* Current interpreter. */
448        Tcl_Obj *keyNameObj,        /* Name of key. */
449        Tcl_Obj *valueNameObj)      /* Name of value to delete. */
450    {
451        HKEY key;
452        char *valueName;
453        int length;
454        DWORD result;
455        Tcl_Obj *resultPtr;
456        Tcl_DString ds;
457    
458        /*
459         * Attempt to open the key for deletion.
460         */
461    
462        if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key)
463                != TCL_OK) {
464            return TCL_ERROR;
465        }
466    
467        resultPtr = Tcl_GetObjResult(interp);
468        valueName = Tcl_GetStringFromObj(valueNameObj, &length);
469        Tcl_WinUtfToTChar(valueName, length, &ds);
470        result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds));
471        Tcl_DStringFree(&ds);
472        if (result != ERROR_SUCCESS) {
473            Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"",
474                    Tcl_GetString(valueNameObj), "\" from key \"",
475                    Tcl_GetString(keyNameObj), "\": ", NULL);
476            AppendSystemError(interp, result);
477            result = TCL_ERROR;
478        } else {
479            result = TCL_OK;
480        }
481        RegCloseKey(key);
482        return result;
483    }
484    
485    /*
486     *----------------------------------------------------------------------
487     *
488     * GetKeyNames --
489     *
490     *      This function enumerates the subkeys of a given key.  If the
491     *      optional pattern is supplied, then only keys that match the
492     *      pattern will be returned.
493     *
494     * Results:
495     *      Returns the list of subkeys in the result object of the
496     *      interpreter, or an error message on failure.
497     *
498     * Side effects:
499     *      None.
500     *
501     *----------------------------------------------------------------------
502     */
503    
504    static int
505    GetKeyNames(
506        Tcl_Interp *interp,         /* Current interpreter. */
507        Tcl_Obj *keyNameObj,        /* Key to enumerate. */
508        Tcl_Obj *patternObj)        /* Optional match pattern. */
509    {
510        HKEY key;
511        DWORD index;
512        char buffer[MAX_PATH+1], *pattern, *name;
513        Tcl_Obj *resultPtr;
514        int result = TCL_OK;
515        Tcl_DString ds;
516    
517        /*
518         * Attempt to open the key for enumeration.
519         */
520    
521        if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key)
522                != TCL_OK) {
523            return TCL_ERROR;
524        }
525    
526        if (patternObj) {
527            pattern = Tcl_GetString(patternObj);
528        } else {
529            pattern = NULL;
530        }
531    
532        /*
533         * Enumerate over the subkeys until we get an error, indicating the
534         * end of the list.
535         */
536    
537        resultPtr = Tcl_GetObjResult(interp);
538        for (index = 0; (*regWinProcs->regEnumKeyProc)(key, index, buffer,
539                MAX_PATH+1) == ERROR_SUCCESS; index++) {
540            Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &ds);
541            name = Tcl_DStringValue(&ds);
542            if (pattern && !Tcl_StringMatch(name, pattern)) {
543                Tcl_DStringFree(&ds);
544                continue;
545            }
546            result = Tcl_ListObjAppendElement(interp, resultPtr,
547                    Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
548            Tcl_DStringFree(&ds);
549            if (result != TCL_OK) {
550                break;
551            }
552        }
553    
554        RegCloseKey(key);
555        return result;
556    }
557    
558    /*
559     *----------------------------------------------------------------------
560     *
561     * GetType --
562     *
563     *      This function gets the type of a given registry value and
564     *      places it in the interpreter result.
565     *
566     * Results:
567     *      Returns a normal Tcl result.
568     *
569     * Side effects:
570     *      None.
571     *
572     *----------------------------------------------------------------------
573     */
574    
575    static int
576    GetType(
577        Tcl_Interp *interp,         /* Current interpreter. */
578        Tcl_Obj *keyNameObj,        /* Name of key. */
579        Tcl_Obj *valueNameObj)      /* Name of value to get. */
580    {
581        HKEY key;
582        Tcl_Obj *resultPtr;
583        DWORD result;
584        DWORD type;
585        Tcl_DString ds;
586        char *valueName;
587        int length;
588    
589        /*
590         * Attempt to open the key for reading.
591         */
592    
593        if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
594                != TCL_OK) {
595            return TCL_ERROR;
596        }
597    
598        /*
599         * Get the type of the value.
600         */
601    
602        resultPtr = Tcl_GetObjResult(interp);
603    
604        valueName = Tcl_GetStringFromObj(valueNameObj, &length);
605        valueName = Tcl_WinUtfToTChar(valueName, length, &ds);
606        result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type,
607                NULL, NULL);
608        Tcl_DStringFree(&ds);
609        RegCloseKey(key);
610    
611        if (result != ERROR_SUCCESS) {
612            Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"",
613                    Tcl_GetString(valueNameObj), "\" from key \"",
614                    Tcl_GetString(keyNameObj), "\": ", NULL);
615            AppendSystemError(interp, result);
616            return TCL_ERROR;
617        }
618    
619        /*
620         * Set the type into the result.  Watch out for unknown types.
621         * If we don't know about the type, just use the numeric value.
622         */
623    
624        if (type > lastType || type < 0) {
625            Tcl_SetIntObj(resultPtr, type);
626        } else {
627            Tcl_SetStringObj(resultPtr, typeNames[type], -1);
628        }
629        return TCL_OK;
630    }
631    
632    /*
633     *----------------------------------------------------------------------
634     *
635     * GetValue --
636     *
637     *      This function gets the contents of a registry value and places
638     *      a list containing the data and the type in the interpreter
639     *      result.
640     *
641     * Results:
642     *      Returns a normal Tcl result.
643     *
644     * Side effects:
645     *      None.
646     *
647     *----------------------------------------------------------------------
648     */
649    
650    static int
651    GetValue(
652        Tcl_Interp *interp,         /* Current interpreter. */
653        Tcl_Obj *keyNameObj,        /* Name of key. */
654        Tcl_Obj *valueNameObj)      /* Name of value to get. */
655    {
656        HKEY key;
657        char *valueName;
658        DWORD result, length, type;
659        Tcl_Obj *resultPtr;
660        Tcl_DString data, buf;
661        int nameLen;
662    
663        /*
664         * Attempt to open the key for reading.
665         */
666    
667        if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
668                != TCL_OK) {
669            return TCL_ERROR;
670        }
671    
672        /*
673         * Initialize a Dstring to maximum statically allocated size
674         * we could get one more byte by avoiding Tcl_DStringSetLength()
675         * and just setting length to TCL_DSTRING_STATIC_SIZE, but this
676         * should be safer if the implementation of Dstrings changes.
677         *
678         * This allows short values to be read from the registy in one call.
679         * Longer values need a second call with an expanded DString.
680         */
681    
682        Tcl_DStringInit(&data);
683        length = TCL_DSTRING_STATIC_SIZE - 1;
684        Tcl_DStringSetLength(&data, length);
685    
686        resultPtr = Tcl_GetObjResult(interp);
687    
688        valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);
689        valueName = Tcl_WinUtfToTChar(valueName, nameLen, &buf);
690    
691        result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type,
692                (BYTE *) Tcl_DStringValue(&data), &length);
693        while (result == ERROR_MORE_DATA) {
694            /*
695             * The Windows docs say that in this error case, we just need
696             * to expand our buffer and request more data.
697             * Required for HKEY_PERFORMANCE_DATA
698             */
699            length *= 2;
700            Tcl_DStringSetLength(&data, length);
701            result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL,
702                    &type, (BYTE *) Tcl_DStringValue(&data), &length);
703        }
704        Tcl_DStringFree(&buf);
705        RegCloseKey(key);
706        if (result != ERROR_SUCCESS) {
707            Tcl_AppendStringsToObj(resultPtr, "unable to get value \"",
708                    Tcl_GetString(valueNameObj), "\" from key \"",
709                    Tcl_GetString(keyNameObj), "\": ", NULL);
710            AppendSystemError(interp, result);
711            Tcl_DStringFree(&data);
712            return TCL_ERROR;
713        }
714    
715        /*
716         * If the data is a 32-bit quantity, store it as an integer object.  If it
717         * is a multi-string, store it as a list of strings.  For null-terminated
718         * strings, append up the to first null.  Otherwise, store it as a binary
719         * string.
720         */
721    
722        if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
723            Tcl_SetIntObj(resultPtr, ConvertDWORD(type,
724                    *((DWORD*) Tcl_DStringValue(&data))));
725        } else if (type == REG_MULTI_SZ) {
726            char *p = Tcl_DStringValue(&data);
727            char *end = Tcl_DStringValue(&data) + length;
728    
729            /*
730             * Multistrings are stored as an array of null-terminated strings,
731             * terminated by two null characters.  Also do a bounds check in
732             * case we get bogus data.
733             */
734    
735            while (p < end  && ((regWinProcs->useWide)
736                    ? *((Tcl_UniChar *)p) : *p) != 0) {
737                Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
738                Tcl_ListObjAppendElement(interp, resultPtr,
739                        Tcl_NewStringObj(Tcl_DStringValue(&buf),
740                                Tcl_DStringLength(&buf)));
741                if (regWinProcs->useWide) {
742                    while (*((Tcl_UniChar *)p)++ != 0) {}
743                } else {
744                    while (*p++ != '\0') {}
745                }
746                Tcl_DStringFree(&buf);
747            }
748        } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
749            Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf);
750            Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buf),
751                    Tcl_DStringLength(&buf));
752            Tcl_DStringFree(&buf);
753        } else {
754            /*
755             * Save binary data as a byte array.
756             */
757    
758            Tcl_SetByteArrayObj(resultPtr, Tcl_DStringValue(&data), length);
759        }
760        Tcl_DStringFree(&data);
761        return result;
762    }
763    
764    /*
765     *----------------------------------------------------------------------
766     *
767     * GetValueNames --
768     *
769     *      This function enumerates the values of the a given key.  If
770     *      the optional pattern is supplied, then only value names that
771     *      match the pattern will be returned.
772     *
773     * Results:
774     *      Returns the list of value names in the result object of the
775     *      interpreter, or an error message on failure.
776     *
777     * Side effects:
778     *      None.
779     *
780     *----------------------------------------------------------------------
781     */
782    
783    static int
784    GetValueNames(
785        Tcl_Interp *interp,         /* Current interpreter. */
786        Tcl_Obj *keyNameObj,        /* Key to enumerate. */
787        Tcl_Obj *patternObj)        /* Optional match pattern. */
788    {
789        HKEY key;
790        Tcl_Obj *resultPtr;
791        DWORD index, size, maxSize, result;
792        Tcl_DString buffer, ds;
793        char *pattern, *name;
794    
795        /*
796         * Attempt to open the key for enumeration.
797         */
798    
799        if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
800                != TCL_OK) {
801            return TCL_ERROR;
802        }
803    
804        resultPtr = Tcl_GetObjResult(interp);
805    
806        /*
807         * Query the key to determine the appropriate buffer size to hold the
808         * largest value name plus the terminating null.
809         */
810    
811        result = (*regWinProcs->regQueryInfoKeyProc)(key, NULL, NULL, NULL, NULL,
812                NULL, NULL, &index, &maxSize, NULL, NULL, NULL);
813        if (result != ERROR_SUCCESS) {
814            Tcl_AppendStringsToObj(resultPtr, "unable to query key \"",
815                    Tcl_GetString(keyNameObj), "\": ", NULL);
816            AppendSystemError(interp, result);
817            RegCloseKey(key);
818            result = TCL_ERROR;
819            goto done;
820        }
821        maxSize++;
822    
823    
824        Tcl_DStringInit(&buffer);
825        Tcl_DStringSetLength(&buffer,
826                (regWinProcs->useWide) ? maxSize*2 : maxSize);
827        index = 0;
828        result = TCL_OK;
829    
830        if (patternObj) {
831            pattern = Tcl_GetString(patternObj);
832        } else {
833            pattern = NULL;
834        }
835    
836        /*
837         * Enumerate the values under the given subkey until we get an error,
838         * indicating the end of the list.  Note that we need to reset size
839         * after each iteration because RegEnumValue smashes the old value.
840         */
841    
842        size = maxSize;
843        while ((*regWinProcs->regEnumValueProc)(key, index,
844                Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL)
845                == ERROR_SUCCESS) {
846    
847            if (regWinProcs->useWide) {
848                size *= 2;
849            }
850    
851            Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), size, &ds);
852            name = Tcl_DStringValue(&ds);
853            if (!pattern || Tcl_StringMatch(name, pattern)) {
854                result = Tcl_ListObjAppendElement(interp, resultPtr,
855                        Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
856                if (result != TCL_OK) {
857                    Tcl_DStringFree(&ds);
858                    break;
859                }
860            }
861            Tcl_DStringFree(&ds);
862    
863            index++;
864            size = maxSize;
865        }
866        Tcl_DStringFree(&buffer);
867    
868        done:
869        RegCloseKey(key);
870        return result;
871    }
872    
873    /*
874     *----------------------------------------------------------------------
875     *
876     * OpenKey --
877     *
878     *      This function opens the specified key.  This function is a
879     *      simple wrapper around ParseKeyName and OpenSubKey.
880     *
881     * Results:
882     *      Returns the opened key in the keyPtr argument and a Tcl
883     *      result code.
884     *
885     * Side effects:
886     *      None.
887     *
888     *----------------------------------------------------------------------
889     */
890    
891    static int
892    OpenKey(
893        Tcl_Interp *interp,         /* Current interpreter. */
894        Tcl_Obj *keyNameObj,        /* Key to open. */
895        REGSAM mode,                /* Access mode. */
896        int flags,                  /* 0 or REG_CREATE. */
897        HKEY *keyPtr)               /* Returned HKEY. */
898    {
899        char *keyName, *buffer, *hostName;
900        int length;
901        HKEY rootKey;
902        DWORD result;
903    
904        keyName = Tcl_GetStringFromObj(keyNameObj, &length);
905        buffer = ckalloc(length + 1);
906        strcpy(buffer, keyName);
907    
908        result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
909        if (result == TCL_OK) {
910            result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr);
911            if (result != ERROR_SUCCESS) {
912                Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
913                Tcl_AppendToObj(resultPtr, "unable to open key: ", -1);
914                AppendSystemError(interp, result);
915                result = TCL_ERROR;
916            } else {
917                result = TCL_OK;
918            }
919        }
920    
921        ckfree(buffer);
922        return result;
923    }
924    
925    /*
926     *----------------------------------------------------------------------
927     *
928     * OpenSubKey --
929     *
930     *      This function opens a given subkey of a root key on the
931     *      specified host.
932     *
933     * Results:
934     *      Returns the opened key in the keyPtr and a Windows error code
935     *      as the return value.
936     *
937     * Side effects:
938     *      None.
939     *
940     *----------------------------------------------------------------------
941     */
942    
943    static DWORD
944    OpenSubKey(
945        char *hostName,             /* Host to access, or NULL for local. */
946        HKEY rootKey,               /* Root registry key. */
947        char *keyName,              /* Subkey name. */
948        REGSAM mode,                /* Access mode. */
949        int flags,                  /* 0 or REG_CREATE. */
950        HKEY *keyPtr)               /* Returned HKEY. */
951    {
952        DWORD result;
953        Tcl_DString buf;
954    
955        /*
956         * Attempt to open the root key on a remote host if necessary.
957         */
958    
959        if (hostName) {
960            hostName = Tcl_WinUtfToTChar(hostName, -1, &buf);
961            result = (*regWinProcs->regConnectRegistryProc)(hostName, rootKey,
962                    &rootKey);
963            Tcl_DStringFree(&buf);
964            if (result != ERROR_SUCCESS) {
965                return result;
966            }
967        }
968    
969        /*
970         * Now open the specified key with the requested permissions.  Note
971         * that this key must be closed by the caller.
972         */
973    
974        keyName = Tcl_WinUtfToTChar(keyName, -1, &buf);
975        if (flags & REG_CREATE) {
976            DWORD create;
977            result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, "",
978                    REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
979        } else {
980            if (rootKey == HKEY_PERFORMANCE_DATA) {
981                /*
982                 * Here we fudge it for this special root key.
983                 * See MSDN for more info on HKEY_PERFORMANCE_DATA and
984                 * the peculiarities surrounding it
985                 */
986                *keyPtr = HKEY_PERFORMANCE_DATA;
987                result = ERROR_SUCCESS;
988            } else {
989                result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0,
990                        mode, keyPtr);
991            }
992        }
993        Tcl_DStringFree(&buf);
994    
995        /*
996         * Be sure to close the root key since we are done with it now.
997         */
998    
999        if (hostName) {
1000            RegCloseKey(rootKey);
1001        }
1002        return result;
1003    }
1004    
1005    /*
1006     *----------------------------------------------------------------------
1007     *
1008     * ParseKeyName --
1009     *
1010     *      This function parses a key name into the host, root, and subkey
1011     *      parts.
1012     *
1013     * Results:
1014     *      The pointers to the start of the host and subkey names are
1015     *      returned in the hostNamePtr and keyNamePtr variables.  The
1016     *      specified root HKEY is returned in rootKeyPtr.  Returns
1017     *      a standard Tcl result.
1018     *
1019     *
1020     * Side effects:
1021     *      Modifies the name string by inserting nulls.
1022     *
1023     *----------------------------------------------------------------------
1024     */
1025    
1026    static int
1027    ParseKeyName(
1028        Tcl_Interp *interp,         /* Current interpreter. */
1029        char *name,
1030        char **hostNamePtr,
1031        HKEY *rootKeyPtr,
1032        char **keyNamePtr)
1033    {
1034        char *rootName;
1035        int result, index;
1036        Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp);
1037    
1038        /*
1039         * Split the key into host and root portions.
1040         */
1041    
1042        *hostNamePtr = *keyNamePtr = rootName = NULL;
1043        if (name[0] == '\\') {
1044            if (name[1] == '\\') {
1045                *hostNamePtr = name;
1046                for (rootName = name+2; *rootName != '\0'; rootName++) {
1047                    if (*rootName == '\\') {
1048                        *rootName++ = '\0';
1049                        break;
1050                    }
1051                }
1052            }
1053        } else {
1054            rootName = name;
1055        }
1056        if (!rootName) {
1057            Tcl_AppendStringsToObj(resultPtr, "bad key \"", name,
1058                    "\": must start with a valid root", NULL);
1059            return TCL_ERROR;
1060        }
1061    
1062        /*
1063         * Split the root into root and subkey portions.
1064         */
1065    
1066        for (*keyNamePtr = rootName; **keyNamePtr != '\0'; (*keyNamePtr)++) {
1067            if (**keyNamePtr == '\\') {
1068                **keyNamePtr = '\0';
1069                (*keyNamePtr)++;
1070                break;
1071            }
1072        }
1073    
1074        /*
1075         * Look for a matching root name.
1076         */
1077    
1078        rootObj = Tcl_NewStringObj(rootName, -1);
1079        result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name",
1080                TCL_EXACT, &index);
1081        Tcl_DecrRefCount(rootObj);
1082        if (result != TCL_OK) {
1083            return TCL_ERROR;
1084        }
1085        *rootKeyPtr = rootKeys[index];
1086        return TCL_OK;
1087    }
1088    
1089    /*
1090     *----------------------------------------------------------------------
1091     *
1092     * RecursiveDeleteKey --
1093     *
1094     *      This function recursively deletes all the keys below a starting
1095     *      key.  Although Windows 95 does this automatically, we still need
1096     *      to do this for Windows NT.
1097     *
1098     * Results:
1099     *      Returns a Windows error code.
1100     *
1101     * Side effects:
1102     *      Deletes all of the keys and values below the given key.
1103     *
1104     *----------------------------------------------------------------------
1105     */
1106    
1107    static DWORD
1108    RecursiveDeleteKey(
1109        HKEY startKey,              /* Parent of key to be deleted. */
1110        char *keyName)              /* Name of key to be deleted in external
1111                                     * encoding, not UTF. */
1112    {
1113        DWORD result, size, maxSize;
1114        Tcl_DString subkey;
1115        HKEY hKey;
1116    
1117        /*
1118         * Do not allow NULL or empty key name.
1119         */
1120    
1121        if (!keyName || *keyName == '\0') {
1122            return ERROR_BADKEY;
1123        }
1124    
1125        result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0,
1126                KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey);
1127        if (result != ERROR_SUCCESS) {
1128            return result;
1129        }
1130        result = (*regWinProcs->regQueryInfoKeyProc)(hKey, NULL, NULL, NULL, NULL,
1131                &maxSize, NULL, NULL, NULL, NULL, NULL, NULL);
1132        maxSize++;
1133        if (result != ERROR_SUCCESS) {
1134            return result;
1135        }
1136    
1137        Tcl_DStringInit(&subkey);
1138        Tcl_DStringSetLength(&subkey,
1139                (regWinProcs->useWide) ? maxSize * 2 : maxSize);
1140    
1141        while (result == ERROR_SUCCESS) {
1142            /*
1143             * Always get index 0 because key deletion changes ordering.
1144             */
1145    
1146            size = maxSize;
1147            result=(*regWinProcs->regEnumKeyExProc)(hKey, 0,
1148                    Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL);
1149            if (result == ERROR_NO_MORE_ITEMS) {
1150                result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName);
1151                break;
1152            } else if (result == ERROR_SUCCESS) {
1153                result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey));
1154            }
1155        }
1156        Tcl_DStringFree(&subkey);
1157        RegCloseKey(hKey);
1158        return result;
1159    }
1160    
1161    /*
1162     *----------------------------------------------------------------------
1163     *
1164     * SetValue --
1165     *
1166     *      This function sets the contents of a registry value.  If
1167     *      the key or value does not exist, it will be created.  If it
1168     *      does exist, then the data and type will be replaced.
1169     *
1170     * Results:
1171     *      Returns a normal Tcl result.
1172     *
1173     * Side effects:
1174     *      May create new keys or values.
1175     *
1176     *----------------------------------------------------------------------
1177     */
1178    
1179    static int
1180    SetValue(
1181        Tcl_Interp *interp,         /* Current interpreter. */
1182        Tcl_Obj *keyNameObj,        /* Name of key. */
1183        Tcl_Obj *valueNameObj,      /* Name of value to set. */
1184        Tcl_Obj *dataObj,           /* Data to be written. */
1185        Tcl_Obj *typeObj)           /* Type of data to be written. */
1186    {
1187        DWORD type, result;
1188        HKEY key;
1189        int length;
1190        char *valueName;
1191        Tcl_Obj *resultPtr;
1192        Tcl_DString nameBuf;
1193    
1194        if (typeObj == NULL) {
1195            type = REG_SZ;
1196        } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type",
1197                0, (int *) &type) != TCL_OK) {
1198            if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) {
1199                return TCL_ERROR;
1200            }
1201            Tcl_ResetResult(interp);
1202        }
1203        if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
1204            return TCL_ERROR;
1205        }
1206    
1207        valueName = Tcl_GetStringFromObj(valueNameObj, &length);
1208        valueName = Tcl_WinUtfToTChar(valueName, length, &nameBuf);
1209        resultPtr = Tcl_GetObjResult(interp);
1210    
1211        if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
1212            DWORD value;
1213            if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) {
1214                RegCloseKey(key);
1215                Tcl_DStringFree(&nameBuf);
1216                return TCL_ERROR;
1217            }
1218    
1219            value = ConvertDWORD(type, value);
1220            result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
1221                    (BYTE*) &value, sizeof(DWORD));
1222        } else if (type == REG_MULTI_SZ) {
1223            Tcl_DString data, buf;
1224            int objc, i;
1225            Tcl_Obj **objv;
1226    
1227            if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
1228                RegCloseKey(key);
1229                Tcl_DStringFree(&nameBuf);
1230                return TCL_ERROR;
1231            }
1232    
1233            /*
1234             * Append the elements as null terminated strings.  Note that
1235             * we must not assume the length of the string in case there are
1236             * embedded nulls, which aren't allowed in REG_MULTI_SZ values.
1237             */
1238    
1239            Tcl_DStringInit(&data);
1240            for (i = 0; i < objc; i++) {
1241                Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1);
1242    
1243                /*
1244                 * Add a null character to separate this value from the next.
1245                 * We accomplish this by growing the string by one byte.  Since the
1246                 * DString always tacks on an extra null byte, the new byte will
1247                 * already be set to null.
1248                 */
1249    
1250                Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
1251            }
1252    
1253            Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
1254                    &buf);
1255            result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
1256                    (BYTE *) Tcl_DStringValue(&buf),
1257                    (DWORD) Tcl_DStringLength(&buf));
1258            Tcl_DStringFree(&data);
1259            Tcl_DStringFree(&buf);
1260        } else if (type == REG_SZ || type == REG_EXPAND_SZ) {
1261            Tcl_DString buf;
1262            char *data = Tcl_GetStringFromObj(dataObj, &length);
1263    
1264            data = Tcl_WinUtfToTChar(data, length, &buf);
1265    
1266            /*
1267             * Include the null in the length, padding if needed for Unicode.
1268             */
1269    
1270            if (regWinProcs->useWide) {
1271                Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
1272            }
1273            length = Tcl_DStringLength(&buf) + 1;
1274    
1275            result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
1276                    (BYTE*)data, length);
1277            Tcl_DStringFree(&buf);
1278        } else {
1279            char *data;
1280    
1281            /*
1282             * Store binary data in the registry.
1283             */
1284    
1285            data = Tcl_GetByteArrayFromObj(dataObj, &length);
1286            result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
1287                    (BYTE *)data, length);
1288        }
1289        Tcl_DStringFree(&nameBuf);
1290        RegCloseKey(key);
1291        if (result != ERROR_SUCCESS) {
1292            Tcl_AppendToObj(resultPtr, "unable to set value: ", -1);
1293            AppendSystemError(interp, result);
1294            return TCL_ERROR;
1295        }
1296        return TCL_OK;
1297    }
1298    
1299    /*
1300     *----------------------------------------------------------------------
1301     *
1302     * AppendSystemError --
1303     *
1304     *      This routine formats a Windows system error message and places
1305     *      it into the interpreter result.
1306     *
1307     * Results:
1308     *      None.
1309     *
1310     * Side effects:
1311     *      None.
1312     *
1313     *----------------------------------------------------------------------
1314     */
1315    
1316    static void
1317    AppendSystemError(
1318        Tcl_Interp *interp,         /* Current interpreter. */
1319        DWORD error)                /* Result code from error. */
1320    {
1321        int length;
1322        WCHAR *wMsgPtr;
1323        char *msg;
1324        char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
1325        Tcl_DString ds;
1326        Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
1327    
1328        length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
1329                | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
1330                MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) &wMsgPtr,
1331                0, NULL);
1332        if (length == 0) {
1333            char *msgPtr;
1334    
1335            length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM
1336                    | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
1337                    MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr,
1338                    0, NULL);
1339            if (length > 0) {
1340                wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR));
1341                MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr,
1342                        length + 1);
1343                LocalFree(msgPtr);
1344            }
1345        }
1346        if (length == 0) {
1347            if (error == ERROR_CALL_NOT_IMPLEMENTED) {
1348                msg = "function not supported under Win32s";
1349            } else {
1350                sprintf(msgBuf, "unknown error: %d", error);
1351                msg = msgBuf;
1352            }
1353        } else {
1354            Tcl_Encoding encoding;
1355    
1356            encoding = Tcl_GetEncoding(NULL, "unicode");
1357            Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
1358            Tcl_FreeEncoding(encoding);
1359            LocalFree(wMsgPtr);
1360    
1361            msg = Tcl_DStringValue(&ds);
1362            length = Tcl_DStringLength(&ds);
1363    
1364            /*
1365             * Trim the trailing CR/LF from the system message.
1366             */
1367            if (msg[length-1] == '\n') {
1368                msg[--length] = 0;
1369            }
1370            if (msg[length-1] == '\r') {
1371                msg[--length] = 0;
1372            }
1373        }
1374    
1375        sprintf(id, "%d", error);
1376        Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL);
1377        Tcl_AppendToObj(resultPtr, msg, length);
1378    
1379        if (length != 0) {
1380            Tcl_DStringFree(&ds);
1381        }
1382    }
1383    
1384    /*
1385     *----------------------------------------------------------------------
1386     *
1387     * ConvertDWORD --
1388     *
1389     *      This function determines whether a DWORD needs to be byte
1390     *      swapped, and returns the appropriately swapped value.
1391     *
1392     * Results:
1393     *      Returns a converted DWORD.
1394     *
1395     * Side effects:
1396     *      None.
1397     *
1398     *----------------------------------------------------------------------
1399     */
1400    
1401    static DWORD
1402    ConvertDWORD(
1403        DWORD type,                 /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */
1404        DWORD value)                /* The value to be converted. */
1405    {
1406        DWORD order = 1;
1407        DWORD localType;
1408    
1409        /*
1410         * Check to see if the low bit is in the first byte.
1411         */
1412    
1413        localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
1414        return (type != localType) ? SWAPLONG(value) : value;
1415    }
1416    
1417    /* End of tclwinreg.c */
Legend:
Removed from v.64  
changed lines
  Added in v.71
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25