diff options
| -rw-r--r-- | generic/tclStringObj.c | 3 | ||||
| -rw-r--r-- | generic/tclTest.c | 31 | ||||
| -rw-r--r-- | tests/utf.test | 30 |
3 files changed, 63 insertions, 1 deletions
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 2e42e98..3e1df0b 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -578,6 +578,9 @@ Tcl_GetUniChar( if (stringPtr->numChars == TCL_INDEX_NONE) { 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 b87d659..c0b20ad 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -328,6 +328,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; @@ -686,6 +687,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", @@ -7630,6 +7633,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 aaad670..fec0ba4 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -34,6 +34,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 {}}] @@ -1374,10 +1375,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 |