Merge 8.6 - Fix [b5ac3e3786] - Tcl_GetUniChar oob read

3 files changed, 63 insertions, 1 deletions

diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 490ddf9..251cf66 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -862,6 +862,9 @@ TclGetUniChar(
 	if (stringPtr->numChars == -1) {
 	    TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
 	}
+        if (index >= stringPtr->numChars) {
+            return -1;
+        }
 	if (stringPtr->numChars == objPtr->length) {
 	    return (unsigned char) objPtr->bytes[index];
 	}
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 83dad7d..abfa0ad 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -358,6 +358,7 @@ static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory;
 static Tcl_ObjCmdProc	TestUtfNextCmd;
 static Tcl_ObjCmdProc	TestUtfPrevCmd;
 static Tcl_ObjCmdProc	TestNumUtfCharsCmd;
+static Tcl_ObjCmdProc	TestGetUniCharCmd;
 static Tcl_ObjCmdProc	TestFindFirstCmd;
 static Tcl_ObjCmdProc	TestFindLastCmd;
 static Tcl_ObjCmdProc	TestHashSystemHashCmd;
@@ -718,6 +719,8 @@ Tcltest_Init(
 	    TestUtfPrevCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "testnumutfchars",
 	    TestNumUtfCharsCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testgetunichar",
+                         TestGetUniCharCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "testfindfirst",
 	    TestFindFirstCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "testfindlast",
@@ -7754,6 +7757,34 @@ TestNumUtfCharsCmd(
     return TCL_OK;
 }
 
+
+/*
+ * Used to check correct operation of Tcl_GetUniChar
+ * testgetunichar STRING INDEX
+ * This differs from just using "string index" in being a direct
+ * call to Tcl_GetUniChar without any prior range checking.
+ */
+static int
+TestGetUniCharCmd(
+    ClientData dummy,	/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter */
+    int objc,			/* Number of arguments */
+    Tcl_Obj *const objv[]	/* Argument strings */
+    )
+{
+    int index;
+    int c ;
+    if (objc != 3) {
+       	Tcl_WrongNumArgs(interp, 1, objv, "STRING INDEX");
+	return TCL_ERROR; 
+    }
+    Tcl_GetIntFromObj(interp, objv[2], &index);
+    c = Tcl_GetUniChar(objv[1], index);
+    Tcl_SetObjResult(interp, Tcl_NewIntObj(c));
+
+    return TCL_OK;
+}
+
 /*
  * Used to check correct operation of Tcl_UtfFindFirst
  */
diff --git a/tests/utf.test b/tests/utf.test
index 5a6bbd4..edd0c79 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -36,6 +36,7 @@ testConstraint testnumutfchars [llength [info commands testnumutfchars]]
 testConstraint teststringobj [llength [info commands teststringobj]]
 testConstraint testutfnext [llength [info commands testutfnext]]
 testConstraint testutfprev [llength [info commands testutfprev]]
+testConstraint testgetunichar [llength [info commands testgetunichar]]
 
 testConstraint tip413 [expr {[string trim \x00] eq {}}]
 
@@ -1373,10 +1374,37 @@ test utf-26.1 {Tcl_UniCharDString} -setup {
     scan [string index [teststringobj get 1] 11] %c
 } -result 128
 
-
 unset count
 rename UniCharCaseCmpTest {}
 
+proc GetUniCharTest {s index result} {
+    variable count
+    # Use quotes, not {} so test output shows exact string on error
+    test getunichar-1.$count "Tcl_GetUniChar $s $index" \
+        -constraints testgetunichar \
+        -body "testgetunichar $s $index" \
+        -result $result
+    incr count
+}
+variable count 1
+set errorIndicator -1
+GetUniCharTest abcd -2   $errorIndicator
+GetUniCharTest abcd -1   $errorIndicator
+GetUniCharTest abcd  0   97 ;# a -> ASCII 97
+GetUniCharTest abcd  3   100
+GetUniCharTest abcd  4    $errorIndicator
+GetUniCharTest abcd  1000 $errorIndicator
+
+GetUniCharTest \xe0bc\xe1 -2   $errorIndicator
+GetUniCharTest \xe0bc\xe1 -1   $errorIndicator
+GetUniCharTest \xe0bc\xe1  0   224 ;# \xe0 == 224
+GetUniCharTest \xe0bc\xe1  3   225
+GetUniCharTest \xe0bc\xe1  4    $errorIndicator
+GetUniCharTest \xe0bc\xe1  1000 $errorIndicator
+
+unset count
+rename GetUniCharTest ""
+
 # cleanup
 ::tcltest::cleanupTests
 return