merge trunk

9 files changed, 55 insertions, 31 deletions

diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index cb252b3..11ba2a5 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -10,6 +10,7 @@
  */
 
 #include "tclInt.h"
+#include <assert.h>
 
 typedef size_t (LengthProc)(const char *src);
 
@@ -3476,16 +3477,13 @@ TableToUtfProc(
 	}
 	byte = *((unsigned char *) src);
 	if (prefixBytes[byte]) {
-	    src++;
-	    if (src >= srcEnd) {
+	    if (src >= srcEnd-1) {
+                /* Prefix byte but nothing after it */
 		if (!(flags & TCL_ENCODING_END)) {
-                    /* Suffix bytes expected, don't consume prefix */
-		    src--;
+                    /* More data to come */
 		    result = TCL_CONVERT_MULTIBYTE;
 		    break;
 		} else if (PROFILE_STRICT(flags)) {
-                    /* Truncation. Do not consume so error location correct */
-		    src--;
 		    result = TCL_CONVERT_SYNTAX;
 		    break;
 		} else if (PROFILE_REPLACE(flags)) {
@@ -3494,6 +3492,7 @@ TableToUtfProc(
 		    ch = (unsigned) byte;
 		}
 	    } else {
+                ++src;
 		ch = toUnicode[byte][*((unsigned char *)src)];
 	    }
 	} else {
@@ -3527,6 +3526,7 @@ TableToUtfProc(
 	src++;
     }
 
+    assert(src <= srcEnd);
     *srcReadPtr = src - srcStart;
     *dstWrotePtr = dst - dstStart;
     *dstCharsPtr = numChars;
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index ef3a0f9..0698e61 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -9527,6 +9527,7 @@ EvalStatsCmd(
     size_t refCountSum, literalMgmtBytes, sum, decadeHigh, length;
     size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade;
     Tcl_Size i;
+    size_t ui;
     char *litTableStats;
     LiteralEntry *entryPtr;
     Tcl_Obj *objPtr;
@@ -9662,7 +9663,7 @@ EvalStatsCmd(
     strBytesIfUnshared = 0.0;
     strBytesSharedMultX = 0.0;
     strBytesSharedOnce = 0.0;
-    for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
+    for (ui = 0;  ui < globalTablePtr->numBuckets;  ui++) {
 	for (entryPtr = globalTablePtr->buckets[i];  entryPtr != NULL;
 		entryPtr = entryPtr->nextPtr) {
 	    if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) {
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 92632e8..324a0cc 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -102,6 +102,7 @@
 static void uniCodePanic() {
     Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
 }
+
 #   define Tcl_GetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, Tcl_Size *))(void *)uniCodePanic
 #   define TclGetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic
 #   define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c
index d8a6e5a..f9f2fda 100644
--- a/generic/tclTestABSList.c
+++ b/generic/tclTestABSList.c
@@ -40,6 +40,7 @@ static int my_LStringGetElements(Tcl_Interp *interp,
 				 Tcl_Obj *listPtr,
 				 Tcl_Size *objcptr,
 				 Tcl_Obj ***objvptr);
+static void lstringFreeElements(Tcl_Obj* lstringObj);
 static void UpdateStringOfLString(Tcl_Obj *objPtr);
 
 /*
@@ -608,8 +609,9 @@ my_LStringReplace(
     lstringRep->string = newStr;
     lstringRep->strlen = newLen;
 
-    /* Changes made to value, string rep no longer valid */
+    /* Changes made to value, string rep and elements array no longer valid */
     Tcl_InvalidateStringRep(listObj);
+    lstringFreeElements(listObj);
 
     return TCL_OK;
 }
@@ -701,13 +703,35 @@ my_NewLStringObj(
     } else {
 	Tcl_InitStringRep(lstringPtr, NULL, 0);
     }
-
     return lstringPtr;
 }
 
 /*
  *----------------------------------------------------------------------
  *
+ * freeElements --
+ *
+ *      Free the element array
+ *
+ */
+
+static void
+lstringFreeElements(Tcl_Obj* lstringObj)
+{
+    LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
+    if (lstringRepPtr->elements) {
+	Tcl_Obj **objptr = lstringRepPtr->elements;
+	while (objptr < &lstringRepPtr->elements[lstringRepPtr->strlen]) {
+	    Tcl_DecrRefCount(*objptr++);
+	}
+	Tcl_Free((char*)lstringRepPtr->elements);
+	lstringRepPtr->elements = NULL;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * freeRep --
  *
  *	Free the value storage of the lstring Obj.
@@ -728,14 +752,7 @@ freeRep(Tcl_Obj* lstringObj)
     if (lstringRepPtr->string) {
 	Tcl_Free(lstringRepPtr->string);
     }
-    if (lstringRepPtr->elements) {
-	Tcl_Obj **objptr = lstringRepPtr->elements;
-	while (objptr < &lstringRepPtr->elements[lstringRepPtr->strlen]) {
-	    Tcl_DecrRefCount(*objptr++);
-	}
-	Tcl_Free((char*)lstringRepPtr->elements);
-	lstringRepPtr->elements = NULL;
-    }
+    lstringFreeElements(lstringObj);
     Tcl_Free((char*)lstringRepPtr);
     lstringObj->internalRep.twoPtrValue.ptr1 = NULL;
 }
@@ -773,7 +790,7 @@ static int my_LStringGetElements(Tcl_Interp *interp,
     if (lstringRepPtr->elements == NULL) {
 	lstringRepPtr->elements = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * lstringRepPtr->strlen);
 	objPtr=lstringRepPtr->elements;
-	while (objPtr<&lstringRepPtr->elements[lstringRepPtr->strlen]) {
+	while (objPtr < &lstringRepPtr->elements[lstringRepPtr->strlen]) {
 	    *objPtr = Tcl_NewStringObj(cptr++,1);
 	    Tcl_IncrRefCount(*objPtr++);
 	}
@@ -944,13 +961,11 @@ lgen(
 	int status = Tcl_EvalObjEx(intrp, genCmd, flags);
 	elemObj = Tcl_GetObjResult(intrp);
 	if (status != TCL_OK) {
-	    fprintf(stderr,"Error: %s\nwhile executing %s\n",
-		   elemObj ? Tcl_GetString(elemObj) : "NULL",
-		   Tcl_GetString(genCmd));
+	    Tcl_SetObjResult(intrp, Tcl_ObjPrintf(
+	        "Error: %s\nwhile executing %s\n",
+		elemObj ? Tcl_GetString(elemObj) : "NULL", Tcl_GetString(genCmd)));
+	    return NULL;
 	}
-	// Interp may be only holder of the result,
-	// incr refCount to hold on to it.
-	Tcl_IncrRefCount(elemObj);
     }
     return elemObj;
 }
diff --git a/tests/abstractlist.test b/tests/abstractlist.test
index bf89ef1..4335daa 100644
--- a/tests/abstractlist.test
+++ b/tests/abstractlist.test
@@ -123,7 +123,7 @@ test abstractlist-2.6 {no shimmer ledit} {
     list ${l-isa} $e ${e-isa}
 } {lstring {V i z z i n i : { } S H E { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring}
 
-test abstractlist-2.7 {no shimmer linsert} {
+test abstractlist-2.7 {no shimmer linsert} -body {
     # "ledit m 9 8 S"
     set l [lstring $str2]
     set l-isa [testobj objtype $l]
@@ -134,7 +134,9 @@ test abstractlist-2.7 {no shimmer linsert} {
     set p-isa [testobj objtype $p]
     set i-isa2 [testobj objtype $i]
     lappend res $p ${p-isa} $i ${i-isa2}
-} {lstring {V i z z i n i : { } H E { } a l m o s t { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring ' none {V i z z i n i : { } H E { } a l m o s t { } D I D N T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring}
+} -cleanup {
+unset l i l-isa i-isa res p p-isa
+} -result {lstring {V i z z i n i : { } H E { } a l m o s t { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring ' none {V i z z i n i : { } H E { } a l m o s t { } D I D N T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring}
 
 test abstractlist-2.8 {shimmer lassign} {
     set l [lstring Inconceivable]
diff --git a/tests/chanio.test b/tests/chanio.test
index 8a27acb..5a793d6 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -1090,10 +1090,9 @@ test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} -bod
 } -cleanup {
     chan close $f
 } -result {10 1234567890 0}
-# This testcase fails in "debug" builds. See: [5be203d6ca]
 test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup {
     set x ""
-} -constraints {testchannel ndebug} -body {
+} -constraints {testchannel} -body {
     set f [open $path(test1) w]
     chan configure $f -encoding binary
     chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
diff --git a/tests/io.test b/tests/io.test
index 265eb5e..0fed043 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -1189,8 +1189,7 @@ test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
     close $f
     set x
 } [list 10 "1234567890" 0]
-# This testcase fails in "debug" builds. See: [5be203d6ca]
-test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel ndebug} {
+test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
     set f [open $path(test1) w]
     fconfigure $f -encoding binary
     puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl
index 0cabaaa..61366a4 100644
--- a/tests/tcltests.tcl
+++ b/tests/tcltests.tcl
@@ -8,7 +8,6 @@ namespace import ::tcltest::*
 testConstraint exec [llength [info commands exec]]
 testConstraint deprecated [expr {![tcl::build-info no-deprecate]}]
 testConstraint debug [tcl::build-info debug]
-testConstraint ndebug [expr {![tcl::build-info debug]}]
 testConstraint purify [tcl::build-info purify]
 testConstraint debugpurify [
     expr {
diff --git a/tests/utfext.test b/tests/utfext.test
index bef1fa7..0670502 100644
--- a/tests/utfext.test
+++ b/tests/utfext.test
@@ -74,6 +74,14 @@ test xx-bufferoverflow {buffer overflow Tcl_ExternalToUtf} -body {
 # % testencoding Tcl_ExternalToUtf utf-8 abcdefgh {start end noterminate charlimit} {} 20 rv wv cv
 # nospace {} abcÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ
 
+test TableToUtf-bug-5be203d6ca {Bug 5be203d6ca - truncated prefix in table encoding} -body {
+    set src \x82\x4f\x82\x50\x82 
+    lassign [testencoding Tcl_ExternalToUtf shiftjis $src {start} 0 16 srcRead dstWritten charsWritten] buf 
+    set result [list [testencoding Tcl_ExternalToUtf shiftjis $src {start} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten]
+    lappend result {*}[list [testencoding Tcl_ExternalToUtf shiftjis [string range $src $srcRead end] {end} 0 10 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten]
+} -result [list [list multibyte 0 \xEF\xBC\x90\xEF\xBC\x91\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 4 6 2 [list ok 0 \xC2\x82\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 1 2 1]
+
+
 ::tcltest::cleanupTests
 return