tcl/win/tclWinReg.c

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