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