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