util/src/TclTk/tcl8.6.12/win/tclWinReg.c

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