Check-in [978ad0ba66]
Not logged in

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: 978ad0ba668b0827b50b4a66fdb77f5e7f450b1e
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
Unified Diff Ignore Whitespace Patch
Changes to library/reg/pkgIndex.tcl.
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.1 \
            [list load [file join $dir tclreg13g.dll] registry]
} else {
    package ifneeded registry 1.3.1 \
            [list load [file join $dir tclreg13.dll] registry]
}



|


|


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
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.1]
	}]} {
	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.1}
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} {







|













|







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
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.1 [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.1 [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)








|






|







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
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.1 [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.1 "$(TCLREGLIB:\=/)" registry]
<<
	type tests.log | more
!endif

runtest: setup $(TCLTEST) dlls $(CAT32)
	set TCL_LIBRARY=$(ROOT:\=/)/library
	$(DEBUGGER) $(TCLTEST) $(SCRIPT)







|





|







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
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.1");
}

/*
 *----------------------------------------------------------------------
 *
 * Registry_Unload --
 *







|







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
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) && *((Tcl_UniChar *) p) != 0) {
	    Tcl_UniChar *up;

	    Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
	    Tcl_ListObjAppendElement(interp, resultPtr,
		    Tcl_NewStringObj(Tcl_DStringValue(&buf),
			    Tcl_DStringLength(&buf)));
	    up = (Tcl_UniChar *) p;

	    while (*up++ != 0) {/* empty body */}
	    p = (char *) up;
	    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 {







|
|





|

|
|







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
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 Unicode.
	 */

	Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
	length = Tcl_DStringLength(&buf) + 1;

	result = RegSetValueEx(key, (TCHAR *) valueName, 0,
		(DWORD) type, (BYTE *) data, (DWORD) length);







|







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
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
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    LRESULT result;
    DWORD_PTR sendResult;
    int timeout = 3000;
    size_t len;
    int unilen;
    const char *str;
    Tcl_Obj *objPtr;



    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 = (char*)Tcl_GetUnicodeFromObj(objv[0], &unilen);


    if (unilen == 0) {
	str = NULL;
    }

    /*
     * Use the ignore the result.
     */

    result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
	    (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult);


    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;







<


>
>












|
>
>
|
|







|
>







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;