diff options
| -rw-r--r-- | generic/tclAssembly.c | 10 | ||||
| -rw-r--r-- | generic/tclCompile.c | 2 | ||||
| -rw-r--r-- | generic/tclEncoding.c | 1 | ||||
| -rwxr-xr-x | library/reg/pkgIndex.tcl | 4 | ||||
| -rw-r--r-- | tests/assemble.test | 85 | ||||
| -rw-r--r-- | tests/registry.test | 4 | ||||
| -rw-r--r-- | win/Makefile.in | 4 | ||||
| -rw-r--r-- | win/makefile.vc | 4 | ||||
| -rw-r--r-- | win/tclWinReg.c | 61 |
9 files changed, 132 insertions, 43 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 4ad31d2..8dd23a0 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -3982,10 +3982,12 @@ UnstackExpiredCatches( while (catchDepth > bbPtr->catchDepth) { --catchDepth; - range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->numCodeBytes = bbPtr->startOffset - range->codeOffset; - catches[catchDepth] = NULL; - catchIndices[catchDepth] = -1; + if (catches[catchDepth] != NULL) { + range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; + range->numCodeBytes = bbPtr->startOffset - range->codeOffset; + catches[catchDepth] = NULL; + catchIndices[catchDepth] = -1; + } } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 82d2d99..317ebaf 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -993,7 +993,7 @@ FreeByteCodeInternalRep( void TclPreserveByteCode( - register ByteCode *codePtr) + register ByteCode *codePtr) { codePtr->refCount++; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index a91e8c2..a08f47d 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -355,6 +355,7 @@ DupEncodingIntRep( Tcl_Obj *dupPtr) { dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); + dupPtr->typePtr = &encodingType; } /* diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index 49fd1ac..b1fe234 100755 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -1,9 +1,9 @@ if {([info commands ::tcl::pkgconfig] eq "") || ([info sharedlibextension] ne ".dll")} return if {[::tcl::pkgconfig get debug]} { - package ifneeded registry 1.3.1 \ + package ifneeded registry 1.3.2 \ [list load [file join $dir tclreg13g.dll] registry] } else { - package ifneeded registry 1.3.1 \ + package ifneeded registry 1.3.2 \ [list load [file join $dir tclreg13.dll] registry] } diff --git a/tests/assemble.test b/tests/assemble.test index e81d0c2..356d18d 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -3279,6 +3279,91 @@ test assemble-51.4 {memory leak testing} memory { } } } 0 + +test assemble-52.1 {Bug 3154ea2759} { + proc __BEGIN {} { + ::tcl::unsupported::assemble { + beginCatch @badLabel + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel + label @badLabel + push 1; # should be pushReturnCode + label @okLabel + endCatch + pop + + beginCatch @badLabel2 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel2 + label @badLabel2 + push 1; # should be pushReturnCode + label @okLabel2 + endCatch + pop + + beginCatch @badLabel3 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel3 + label @badLabel3 + push 1; # should be pushReturnCode + label @okLabel3 + endCatch + pop + + beginCatch @badLabel4 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel4 + label @badLabel4 + push 1; # should be pushReturnCode + label @okLabel4 + endCatch + pop + + beginCatch @badLabel5 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel5 + label @badLabel5 + push 1; # should be pushReturnCode + label @okLabel5 + endCatch + pop + + beginCatch @badLabel6 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel6 + label @badLabel6 + push 1; # should be pushReturnCode + label @okLabel6 + endCatch + pop + } + } + __BEGIN +} {}; # must not crash rename fillTables {} rename assemble {} diff --git a/tests/registry.test b/tests/registry.test index 0f78212..2072559 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -19,7 +19,7 @@ testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::regver [package require registry 1.3.1] + set ::regver [package require registry 1.3.2] }]} { testConstraint reg 1 } @@ -33,7 +33,7 @@ testConstraint english [expr { test registry-1.0 {check if we are testing the right dll} {win reg} { set ::regver -} {1.3.1} +} {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 ...?"}} diff --git a/win/Makefile.in b/win/Makefile.in index e5104f9..d8120d5 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -709,14 +709,14 @@ test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) ./$(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) + 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.1 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) + 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` diff --git a/win/makefile.vc b/win/makefile.vc index 417b096..86573a0 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -588,13 +588,13 @@ test-core: setup $(TCLTEST) dlls $(CAT32) !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]
+ 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.1 "$(TCLREGLIB:\=/)" registry]
+ package ifneeded registry 1.3.2 "$(TCLREGLIB:\=/)" registry]
<<
type tests.log | more
!endif
diff --git a/win/tclWinReg.c b/win/tclWinReg.c index e5bbe9c..5f7fd31 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -163,7 +163,7 @@ Registry_Init( cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); - return Tcl_PkgProvideEx(interp, "registry", "1.3.1", NULL); + return Tcl_PkgProvide(interp, "registry", "1.3.2"); } /* @@ -282,8 +282,8 @@ RegistryObjCmd( } if (Tcl_GetString(objv[n])[0] == '-') { - if (Tcl_GetIndexFromObjStruct(interp, objv[n++], modes, - sizeof(char *), "mode", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[n++], modes, "mode", 0, + &index) != TCL_OK) { return TCL_ERROR; } switch (index) { @@ -299,8 +299,8 @@ RegistryObjCmd( } } - if (Tcl_GetIndexFromObjStruct(interp, objv[n++], subcommands, - sizeof(char *), "option", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[n++], subcommands, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } @@ -520,8 +520,7 @@ DeleteValue( if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to delete value \"%s\" from key \"%s\": ", - Tcl_GetString(valueNameObj), - Tcl_GetString(keyNameObj))); + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -682,8 +681,7 @@ GetType( if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to get type of value \"%s\" from key \"%s\": ", - Tcl_GetString(valueNameObj), - Tcl_GetString(keyNameObj))); + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); return TCL_ERROR; } @@ -694,7 +692,7 @@ GetType( */ if (type > lastType) { - Tcl_SetObjResult(interp, Tcl_NewLongObj((int) type)); + Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type)); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1)); } @@ -778,8 +776,7 @@ GetValue( if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to get value \"%s\" from key \"%s\": ", - Tcl_GetString(valueNameObj), - Tcl_GetString(keyNameObj))); + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); Tcl_DStringFree(&data); return TCL_ERROR; @@ -793,7 +790,7 @@ GetValue( */ if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { - Tcl_SetObjResult(interp, Tcl_NewLongObj((long) ConvertDWORD(type, + Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type, *((DWORD *) Tcl_DStringValue(&data))))); } else if (type == REG_MULTI_SZ) { char *p = Tcl_DStringValue(&data); @@ -806,17 +803,17 @@ GetValue( * we get bogus data. */ - while ((p < end) && *((Tcl_UniChar *) p) != 0) { - Tcl_UniChar *up; + 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))); - up = (Tcl_UniChar *) p; + wp = (WCHAR *) p; - while (*up++ != 0) {/* empty body */} - p = (char *) up; + while (*wp++ != 0) {/* empty body */} + p = (char *) wp; Tcl_DStringFree(&buf); } Tcl_SetObjResult(interp, resultPtr); @@ -1124,8 +1121,8 @@ ParseKeyName( */ rootObj = Tcl_NewStringObj(rootName, -1); - result = Tcl_GetIndexFromObjStruct(interp, rootObj, rootKeyNames, - sizeof(char *), "root name", TCL_EXACT, &index); + result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name", + TCL_EXACT, &index); Tcl_DecrRefCount(rootObj); if (result != TCL_OK) { return TCL_ERROR; @@ -1261,8 +1258,8 @@ SetValue( if (typeObj == NULL) { type = REG_SZ; - } else if (Tcl_GetIndexFromObjStruct(interp, typeObj, typeNames, - sizeof(char *), "type", 0, (int *) &type) != TCL_OK) { + } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type", + 0, (int *) &type) != TCL_OK) { if (Tcl_GetIntFromObj(NULL, typeObj, (int *) &type) != TCL_OK) { return TCL_ERROR; } @@ -1335,7 +1332,7 @@ SetValue( data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* - * Include the null in the length, padding if needed for Unicode. + * Include the null in the length, padding if needed for WCHAR. */ Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); @@ -1396,9 +1393,10 @@ BroadcastValue( DWORD_PTR sendResult; int timeout = 3000; size_t len; - int unilen; const char *str; Tcl_Obj *objPtr; + WCHAR *wstr; + Tcl_DString ds; if (objc == 3) { str = Tcl_GetString(objv[1]); @@ -1411,9 +1409,11 @@ BroadcastValue( } } - str = (char*)Tcl_GetUnicodeFromObj(objv[0], &unilen); - if (unilen == 0) { - str = NULL; + str = Tcl_GetString(objv[0]); + len = objv[0]->length; + wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds); + if (Tcl_DStringLength(&ds) == 0) { + wstr = NULL; } /* @@ -1421,11 +1421,12 @@ BroadcastValue( */ result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, - (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult); + (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_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result)); + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) sendResult)); Tcl_SetObjResult(interp, objPtr); return TCL_OK; |