Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Make tclreg13.dll work in any Unicode environment (either with 32-bit or 64-bit characters). Adopted from Androwish. Thanks to Christian Werner. version -> 1.3.2 |
|---|---|
| Timelines: | family | ancestors | descendants | both | core-8-6-branch |
| Files: | files | file ages | folders |
| SHA1: |
978ad0ba668b0827b50b4a66fdb77f5e |
| User & Date: | jan.nijtmans 2016-05-13 07:49:50.414 |
Context
|
2016-05-13
| ||
| 09:07 | result/sendResult could be 64-bit, so account for that check-in: ce171454ea user: jan.nijtmans tags: core-8-6-branch | |
| 08:01 | Merge core-8-6-branch. Eliminate some unnecessary spacing. check-in: e7796bf5e8 user: jan.nijtmans tags: trunk | |
| 07:49 | Make tclreg13.dll work in any Unicode environment (either with 32-bit or 64-bit characters). Adopted... check-in: 978ad0ba66 user: jan.nijtmans tags: core-8-6-branch | |
| 00:45 | Bug fix: Assembler dereferences a rogue pointer when unstacking an empty exception range. check-in: 665d72dc7b user: kbk tags: core-8-6-branch, bug-3154ea2759 | |
Changes
Changes to library/reg/pkgIndex.tcl.
1 2 3 |
if {([info commands ::tcl::pkgconfig] eq "")
|| ([info sharedlibextension] ne ".dll")} return
if {[::tcl::pkgconfig get debug]} {
| | | | 1 2 3 4 5 6 7 8 9 |
if {([info commands ::tcl::pkgconfig] eq "")
|| ([info sharedlibextension] ne ".dll")} return
if {[::tcl::pkgconfig get debug]} {
package ifneeded registry 1.3.2 \
[list load [file join $dir tclreg13g.dll] registry]
} else {
package ifneeded registry 1.3.2 \
[list load [file join $dir tclreg13.dll] registry]
}
|
Changes to tests/registry.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 |
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
| | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
set ::regver [package require registry 1.3.2]
}]} {
testConstraint reg 1
}
}
# determine the current locale
testConstraint english [expr {
[llength [info commands testlocale]]
&& [string match "English*" [testlocale all ""]]
}]
test registry-1.0 {check if we are testing the right dll} {win reg} {
set ::regver
} {1.3.2}
test registry-1.1 {argument parsing for registry command} {win reg} {
list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1a {argument parsing for registry command} {win reg} {
list [catch {registry -32bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1b {argument parsing for registry command} {win reg} {
|
| ︙ | ︙ |
Changes to win/Makefile.in.
| ︙ | ︙ | |||
709 710 711 712 713 714 715 |
test: test-tcl test-packages
test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE)
TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
-load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \
package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
| | | | 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 |
test: test-tcl test-packages
test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE)
TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
-load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \
package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
package ifneeded registry 1.3.2 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32)
# Useful target to launch a built tclsh with the proper path,...
runtest: binaries $(TCLSH) $(TEST_DLL_FILE)
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \
package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
package ifneeded registry 1.3.2 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT)
# This target can be used to run tclsh from the build directory via
# `make shell SCRIPT=foo.tcl`
shell: binaries
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
./$(TCLSH) $(SCRIPT)
|
| ︙ | ︙ |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
585 586 587 588 589 590 591 | test: test-core test-pkgs test-core: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde] | | | | 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 | test: test-core test-pkgs test-core: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.2 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log package ifneeded dde 1.4.0 "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.2 "$(TCLREGLIB:\=/)" registry] << type tests.log | more !endif runtest: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) $(SCRIPT) |
| ︙ | ︙ |
Changes to win/tclWinReg.c.
| ︙ | ︙ | |||
159 160 161 162 163 164 165 |
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
| | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 |
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
return Tcl_PkgProvide(interp, "registry", "1.3.2");
}
/*
*----------------------------------------------------------------------
*
* Registry_Unload --
*
|
| ︙ | ︙ | |||
799 800 801 802 803 804 805 | /* * Multistrings are stored as an array of null-terminated strings, * terminated by two null characters. Also do a bounds check in case * we get bogus data. */ | | | | | | | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 |
/*
* Multistrings are stored as an array of null-terminated strings,
* terminated by two null characters. Also do a bounds check in case
* we get bogus data.
*/
while ((p < end) && *((WCHAR *) p) != 0) {
WCHAR *wp;
Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf)));
wp = (WCHAR *) p;
while (*wp++ != 0) {/* empty body */}
p = (char *) wp;
Tcl_DStringFree(&buf);
}
Tcl_SetObjResult(interp, resultPtr);
} else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf);
Tcl_DStringResult(interp, &buf);
} else {
|
| ︙ | ︙ | |||
1328 1329 1330 1331 1332 1333 1334 | Tcl_DString buf; const char *data = Tcl_GetString(dataObj); length = dataObj->length; data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* | | | 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 | Tcl_DString buf; const char *data = Tcl_GetString(dataObj); length = dataObj->length; data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* * Include the null in the length, padding if needed for WCHAR. */ Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); length = Tcl_DStringLength(&buf) + 1; result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) data, (DWORD) length); |
| ︙ | ︙ | |||
1389 1390 1391 1392 1393 1394 1395 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
LRESULT result;
DWORD_PTR sendResult;
int timeout = 3000;
size_t len;
| < > > | > > | | | > | 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
LRESULT result;
DWORD_PTR sendResult;
int timeout = 3000;
size_t len;
const char *str;
Tcl_Obj *objPtr;
WCHAR *wstr;
Tcl_DString ds;
if (objc == 3) {
str = Tcl_GetString(objv[1]);
len = objv[1]->length;
if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) {
return TCL_BREAK;
}
if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) {
return TCL_ERROR;
}
}
str = Tcl_GetString(objv[0]);
len = objv[0]->length;
wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds);
if (Tcl_DStringLength(&ds) == 0) {
wstr = NULL;
}
/*
* Use the ignore the result.
*/
result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
(WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult);
Tcl_DStringFree(&ds);
objPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result));
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult));
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
|
| ︙ | ︙ |