diff options
| -rw-r--r-- | doc/string.n | 17 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 58 | ||||
| -rw-r--r-- | generic/tclCompCmdsSZ.c | 57 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 | ||||
| -rw-r--r-- | tests/string.test | 89 |
5 files changed, 221 insertions, 3 deletions
diff --git a/doc/string.n b/doc/string.n index cc3fc54..13b5969 100644 --- a/doc/string.n +++ b/doc/string.n @@ -88,6 +88,23 @@ If \fIcharIndex\fR is less than 0 or greater than or equal to the length of the string then this command returns an empty string. .RE .TP +\fBstring insert \fIstring index insertString\fR +. +Returns a copy of \fIstring\fR with \fIinsertString\fR inserted at the +\fIindex\fR'th character. \fIindex\fR may be specified as described in the +\fBSTRING INDICES\fR section. +.RS +.PP +If \fIindex\fR is start-relative, the first character inserted in the returned +string will be at the specified index. If \fIindex\fR is end-relative, the last +character inserted in the returned string will be at the specified index. +.PP +If \fIindex\fR is at or before the start of \fIstring\fR (e.g., \fIindex\fR is +\fB0\fR), \fIinsertString\fR is prepended to \fIstring\fR. If \fIindex\fR is at +or after the end of \fIstring\fR (e.g., \fIindex\fR is \fBend\fR), +\fIinsertString\fR is appended to \fIstring\fR. +.RE +.TP \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR . Returns 1 if \fIstring\fR is a valid member of the specified character diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d21a521..5be1fe5 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1459,6 +1459,63 @@ StringIndexCmd( /* *---------------------------------------------------------------------- * + * StringInsertCmd -- + * + * This procedure is invoked to process the "string insert" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringInsertCmd( + ClientData dummy, /* Not used */ + Tcl_Interp *interp, /* Current interpreter */ + int objc, /* Number of arguments */ + Tcl_Obj *const objv[]) /* Argument objects */ +{ + int length; /* String length */ + int index; /* Insert index */ + Tcl_Obj *outObj; /* Output object */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string index insertString"); + return TCL_ERROR; + } + + length = Tcl_GetCharLength(objv[1]); + if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) { + return TCL_ERROR; + } + + if (index < 0) { + index = 0; + } + if (index > length) { + index = length; + } + + outObj = TclStringReplace(interp, objv[1], index, 0, objv[3], + TCL_STRING_IN_PLACE); + + if (outObj != NULL) { + Tcl_SetObjResult(interp, outObj); + return TCL_OK; + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * StringIsCmd -- * * This procedure is invoked to process the "string is" Tcl command. See @@ -3268,6 +3325,7 @@ TclInitStringCmd( {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, + {"insert", StringInsertCmd, TclCompileStringInsertCmd, NULL, NULL, 0}, {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 8b54a99..c608017 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -449,6 +449,63 @@ TclCompileStringIndexCmd( } int +TclCompileStringInsertCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + int idx; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + + /* Compute and push the string in which to insert */ + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* See what can be discovered about index at compile time */ + tokenPtr = TokenAfter(tokenPtr); + if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, + TCL_INDEX_END, &idx)) { + + /* Nothing useful knowable - cease compile; let it direct eval */ + return TCL_OK; + } + + /* Compute and push the string to be inserted */ + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + + if (idx == TCL_INDEX_START) { + /* Prepend the insertion string */ + OP4( REVERSE, 2); + OP1( STR_CONCAT1, 2); + } else if (idx == TCL_INDEX_END) { + /* Append the insertion string */ + OP1( STR_CONCAT1, 2); + } else { + /* Prefix + insertion + suffix */ + if (idx < TCL_INDEX_END) { + /* See comments in compiler for [linsert]. */ + idx++; + } + OP4( OVER, 1); + OP44( STR_RANGE_IMM, 0, idx-1); + OP4( REVERSE, 3); + OP44( STR_RANGE_IMM, idx, TCL_INDEX_END); + OP1( STR_CONCAT1, 3); + } + + return TCL_OK; +} + +int TclCompileStringIsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclInt.h b/generic/tclInt.h index cea0179..ffb3e67 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3793,6 +3793,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringInsertCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/tests/string.test b/tests/string.test index 81fe130..a8453ca 100644 --- a/tests/string.test +++ b/tests/string.test @@ -73,7 +73,7 @@ if {$noComp} { test string-1.1.$noComp {error conditions} { list [catch {run {string gorp a b}} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2.$noComp {error conditions} { list [catch {run {string}} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} @@ -1782,7 +1782,7 @@ test string-20.1.$noComp {string trimright errors} { } {1 {wrong # args: should be "string trimright string ?chars?"}} test string-20.2.$noComp {string trimright errors} { list [catch {run {string trimg a}} msg] $msg -} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-20.3.$noComp {string trimright} { run {string trimright " XYZ "} } { XYZ} @@ -1841,7 +1841,7 @@ test string-21.14.$noComp {string wordend, unicode} { test string-22.1.$noComp {string wordstart} { list [catch {run {string word a}} msg] $msg -} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-22.2.$noComp {string wordstart} { list [catch {run {string wordstart a}} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} @@ -2314,6 +2314,89 @@ test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"} } hellohello +# Note: string-31.* tests use [tcl::string::insert] rather than [string insert] +# to dodge ticket [3397978fff] which would cause all arguments to be shared, +# thereby preventing the optimizations from being tested. +test string-31.1.$noComp {string insert, start of string} { + run {tcl::string::insert 0123 0 _} +} _0123 +test string-31.2.$noComp {string insert, middle of string} { + run {tcl::string::insert 0123 2 _} +} 01_23 +test string-31.3.$noComp {string insert, end of string} { + run {tcl::string::insert 0123 4 _} +} 0123_ +test string-31.4.$noComp {string insert, start of string, end-relative} { + run {tcl::string::insert 0123 end-4 _} +} _0123 +test string-31.5.$noComp {string insert, middle of string, end-relative} { + run {tcl::string::insert 0123 end-2 _} +} 01_23 +test string-31.6.$noComp {string insert, end of string, end-relative} { + run {tcl::string::insert 0123 end _} +} 0123_ +test string-31.7.$noComp {string insert, empty target string} { + run {tcl::string::insert {} 0 _} +} _ +test string-31.8.$noComp {string insert, empty insert string} { + run {tcl::string::insert 0123 0 {}} +} 0123 +test string-31.9.$noComp {string insert, empty strings} { + run {tcl::string::insert {} 0 {}} +} {} +test string-31.10.$noComp {string insert, negative index} { + run {tcl::string::insert 0123 -1 _} +} _0123 +test string-31.11.$noComp {string insert, index beyond end} { + run {tcl::string::insert 0123 5 _} +} 0123_ +test string-31.12.$noComp {string insert, start of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 0 [makeByteArray _]} +} _0123 +test string-31.13.$noComp {string insert, middle of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]} +} 01_23 +test string-31.14.$noComp {string insert, end of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 4 [makeByteArray _]} +} 0123_ +test string-31.15.$noComp {string insert, pure byte array, neither shared} { + run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]} +} 01_23 +test string-31.16.$noComp {string insert, pure byte array, first shared} { + run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\ + [makeByteArray _]} +} 01_23 +test string-31.17.$noComp {string insert, pure byte array, second shared} { + run {tcl::string::insert [makeByteArray 0123] 2\ + [makeShared [makeByteArray _]]} +} 01_23 +test string-31.18.$noComp {string insert, pure byte array, both shared} { + run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\ + [makeShared [makeByteArray _]]} +} 01_23 +test string-31.19.$noComp {string insert, start of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 0 [makeUnicode _]} +} _0123 +test string-31.20.$noComp {string insert, middle of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 2 [makeUnicode _]} +} 01_23 +test string-31.21.$noComp {string insert, end of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 4 [makeUnicode _]} +} 0123_ +test string-31.22.$noComp {string insert, str start, pure Uni, first shared} { + run {tcl::string::insert [makeShared [makeUnicode 0123]] 0 [makeUnicode _]} +} _0123 +test string-31.23.$noComp {string insert, string mid, pure Uni, 2nd shared} { + run {tcl::string::insert [makeUnicode 0123] 2 [makeShared [makeUnicode _]]} +} 01_23 +test string-31.24.$noComp {string insert, string end, pure Uni, both shared} { + run {tcl::string::insert [makeShared [makeUnicode 0123]] 4\ + [makeShared [makeUnicode _]]} +} 0123_ +test string-31.25.$noComp {string insert, neither byte array nor Unicode} { + run {tcl::string::insert [makeList a b c] 1 zzzzzz} +} {azzzzzz b c} + test string-31.1.$noComp {string is dict} { string is dict {a b c d} } 1 |