Tcl Source Code

Check-in [831cf8accf]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Implement TIP 504
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-branch
Files: files | file ages | folders
SHA3-256: 831cf8accfec73baa82e0f4bd0abf5ff6014e5a4a58f5a1dde134b1a14b0c107
User & Date: dkf 2019-04-14 14:37:12
Context
2019-04-14
15:14
Doc tweak check-in: 369e478469 user: dkf tags: core-8-branch
14:37
Implement TIP 504 check-in: 831cf8accf user: dkf tags: core-8-branch
14:17
Implement TIP 367 check-in: 48745adfd3 user: dkf tags: core-8-branch
2019-04-12
20:16
merge 8.7 Closed-Leaf check-in: c8c10b1df8 user: dgp tags: dgp-string-insert
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to doc/string.n.

    83     83   string.  \fIcharIndex\fR may be specified as described in the
    84     84   \fBSTRING INDICES\fR section.
    85     85   .RS
    86     86   .PP
    87     87   If \fIcharIndex\fR is less than 0 or greater than or equal to the
    88     88   length of the string then this command returns an empty string.
    89     89   .RE
           90  +.TP
           91  +\fBstring insert \fIstring index insertString\fR
           92  +.
           93  +Returns a copy of \fIstring\fR with \fIinsertString\fR inserted at the
           94  +\fIindex\fR'th character.  \fIindex\fR may be specified as described in the
           95  +\fBSTRING INDICES\fR section.
           96  +.RS
           97  +.PP
           98  +If \fIindex\fR is start-relative, the first character inserted in the returned
           99  +string will be at the specified index.  If \fIindex\fR is end-relative, the last
          100  +character inserted in the returned string will be at the specified index.
          101  +.PP
          102  +If \fIindex\fR is at or before the start of \fIstring\fR (e.g., \fIindex\fR is
          103  +\fB0\fR), \fIinsertString\fR is prepended to \fIstring\fR.  If \fIindex\fR is at
          104  +or after the end of \fIstring\fR (e.g., \fIindex\fR is \fBend\fR),
          105  +\fIinsertString\fR is appended to \fIstring\fR.
          106  +.RE
    90    107   .TP
    91    108   \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR
    92    109   .
    93    110   Returns 1 if \fIstring\fR is a valid member of the specified character
    94    111   class, otherwise returns 0.  If \fB\-strict\fR is specified, then an
    95    112   empty string returns 0, otherwise an empty string will return 1 on
    96    113   any class.  If \fB\-failindex\fR is specified, then if the function

Changes to generic/tclCmdMZ.c.

  1456   1456       }
  1457   1457       return TCL_OK;
  1458   1458   }
  1459   1459   
  1460   1460   /*
  1461   1461    *----------------------------------------------------------------------
  1462   1462    *
         1463  + * StringInsertCmd --
         1464  + *
         1465  + *	This procedure is invoked to process the "string insert" Tcl command.
         1466  + *	See the user documentation for details on what it does. Note that this
         1467  + *	command only functions correctly on properly formed Tcl UTF strings.
         1468  + *
         1469  + * Results:
         1470  + *	A standard Tcl result.
         1471  + *
         1472  + * Side effects:
         1473  + *	See the user documentation.
         1474  + *
         1475  + *----------------------------------------------------------------------
         1476  + */
         1477  +
         1478  +static int
         1479  +StringInsertCmd(
         1480  +    ClientData dummy,		/* Not used */
         1481  +    Tcl_Interp *interp,		/* Current interpreter */
         1482  +    int objc,			/* Number of arguments */
         1483  +    Tcl_Obj *const objv[])	/* Argument objects */
         1484  +{
         1485  +    int length;			/* String length */
         1486  +    int index;			/* Insert index */
         1487  +    Tcl_Obj *outObj;		/* Output object */
         1488  +
         1489  +    if (objc != 4) {
         1490  +	Tcl_WrongNumArgs(interp, 1, objv, "string index insertString");
         1491  +	return TCL_ERROR;
         1492  +    }
         1493  +
         1494  +    length = Tcl_GetCharLength(objv[1]);
         1495  +    if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) {
         1496  +	return TCL_ERROR;
         1497  +    }
         1498  +
         1499  +    if (index < 0) {
         1500  +	index = 0;
         1501  +    }
         1502  +    if (index > length) {
         1503  +	index = length;
         1504  +    }
         1505  +
         1506  +    outObj = TclStringReplace(interp, objv[1], index, 0, objv[3],
         1507  +	    TCL_STRING_IN_PLACE);
         1508  +
         1509  +    if (outObj != NULL) {
         1510  +	Tcl_SetObjResult(interp, outObj);
         1511  +	return TCL_OK;
         1512  +    }
         1513  +
         1514  +    return TCL_ERROR;
         1515  +}
         1516  +
         1517  +/*
         1518  + *----------------------------------------------------------------------
         1519  + *
  1463   1520    * StringIsCmd --
  1464   1521    *
  1465   1522    *	This procedure is invoked to process the "string is" Tcl command. See
  1466   1523    *	the user documentation for details on what it does. Note that this
  1467   1524    *	command only functions correctly on properly formed Tcl UTF strings.
  1468   1525    *
  1469   1526    * Results:
................................................................................
  3265   3322       static const EnsembleImplMap stringImplMap[] = {
  3266   3323   	{"bytelength",	StringBytesCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
  3267   3324   	{"cat",		StringCatCmd,	TclCompileStringCatCmd, NULL, NULL, 0},
  3268   3325   	{"compare",	StringCmpCmd,	TclCompileStringCmpCmd, NULL, NULL, 0},
  3269   3326   	{"equal",	StringEqualCmd,	TclCompileStringEqualCmd, NULL, NULL, 0},
  3270   3327   	{"first",	StringFirstCmd,	TclCompileStringFirstCmd, NULL, NULL, 0},
  3271   3328   	{"index",	StringIndexCmd,	TclCompileStringIndexCmd, NULL, NULL, 0},
         3329  +	{"insert",	StringInsertCmd, TclCompileStringInsertCmd, NULL, NULL, 0},
  3272   3330   	{"is",		StringIsCmd,	TclCompileStringIsCmd, NULL, NULL, 0},
  3273   3331   	{"last",	StringLastCmd,	TclCompileStringLastCmd, NULL, NULL, 0},
  3274   3332   	{"length",	StringLenCmd,	TclCompileStringLenCmd, NULL, NULL, 0},
  3275   3333   	{"map",		StringMapCmd,	TclCompileStringMapCmd, NULL, NULL, 0},
  3276   3334   	{"match",	StringMatchCmd,	TclCompileStringMatchCmd, NULL, NULL, 0},
  3277   3335   	{"range",	StringRangeCmd,	TclCompileStringRangeCmd, NULL, NULL, 0},
  3278   3336   	{"repeat",	StringReptCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},

Changes to generic/tclCompCmdsSZ.c.

   441    441        */
   442    442   
   443    443       tokenPtr = TokenAfter(parsePtr->tokenPtr);
   444    444       CompileWord(envPtr, tokenPtr, interp, 1);
   445    445       tokenPtr = TokenAfter(tokenPtr);
   446    446       CompileWord(envPtr, tokenPtr, interp, 2);
   447    447       TclEmitOpcode(INST_STR_INDEX, envPtr);
          448  +    return TCL_OK;
          449  +}
          450  +
          451  +int
          452  +TclCompileStringInsertCmd(
          453  +    Tcl_Interp *interp,		/* Used for error reporting. */
          454  +    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
          455  +				 * created by Tcl_ParseCommand. */
          456  +    Command *cmdPtr,		/* Points to defintion of command being
          457  +				 * compiled. */
          458  +    CompileEnv *envPtr)		/* Holds resulting instructions. */
          459  +{
          460  +    Tcl_Token *tokenPtr;
          461  +    DefineLineInformation;	/* TIP #280 */
          462  +    int idx;
          463  +
          464  +    if (parsePtr->numWords != 4) {
          465  +	return TCL_ERROR;
          466  +    }
          467  +
          468  +    /* Compute and push the string in which to insert */
          469  +    tokenPtr = TokenAfter(parsePtr->tokenPtr);
          470  +    CompileWord(envPtr, tokenPtr, interp, 1);
          471  +
          472  +    /* See what can be discovered about index at compile time */
          473  +    tokenPtr = TokenAfter(tokenPtr);
          474  +    if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START,
          475  +	    TCL_INDEX_END, &idx)) {
          476  +
          477  +	/* Nothing useful knowable - cease compile; let it direct eval */
          478  +	return TCL_OK;
          479  +    }
          480  +
          481  +    /* Compute and push the string to be inserted */
          482  +    tokenPtr = TokenAfter(tokenPtr);
          483  +    CompileWord(envPtr, tokenPtr, interp, 3);
          484  +
          485  +    if (idx == TCL_INDEX_START) {
          486  +	/* Prepend the insertion string */
          487  +	OP4(	REVERSE, 2);
          488  +	OP1(	STR_CONCAT1, 2);
          489  +    } else  if (idx == TCL_INDEX_END) {
          490  +	/* Append the insertion string */
          491  +	OP1(	STR_CONCAT1, 2);
          492  +    } else {
          493  +	/* Prefix + insertion + suffix */
          494  +	if (idx < TCL_INDEX_END) {
          495  +	    /* See comments in compiler for [linsert]. */
          496  +	    idx++;
          497  +	}
          498  +	OP4(	OVER, 1);
          499  +	OP44(	STR_RANGE_IMM, 0, idx-1);
          500  +	OP4(	REVERSE, 3);
          501  +	OP44(	STR_RANGE_IMM, idx, TCL_INDEX_END);
          502  +	OP1(	STR_CONCAT1, 3);
          503  +    }
          504  +
   448    505       return TCL_OK;
   449    506   }
   450    507   
   451    508   int
   452    509   TclCompileStringIsCmd(
   453    510       Tcl_Interp *interp,		/* Used for error reporting. */
   454    511       Tcl_Parse *parsePtr,	/* Points to a parse structure for the command

Changes to generic/tclInt.h.

  3805   3805   			    Tcl_Parse *parsePtr, Command *cmdPtr,
  3806   3806   			    struct CompileEnv *envPtr);
  3807   3807   MODULE_SCOPE int	TclCompileStringFirstCmd(Tcl_Interp *interp,
  3808   3808   			    Tcl_Parse *parsePtr, Command *cmdPtr,
  3809   3809   			    struct CompileEnv *envPtr);
  3810   3810   MODULE_SCOPE int	TclCompileStringIndexCmd(Tcl_Interp *interp,
  3811   3811   			    Tcl_Parse *parsePtr, Command *cmdPtr,
         3812  +			    struct CompileEnv *envPtr);
         3813  +MODULE_SCOPE int	TclCompileStringInsertCmd(Tcl_Interp *interp,
         3814  +			    Tcl_Parse *parsePtr, Command *cmdPtr,
  3812   3815   			    struct CompileEnv *envPtr);
  3813   3816   MODULE_SCOPE int	TclCompileStringIsCmd(Tcl_Interp *interp,
  3814   3817   			    Tcl_Parse *parsePtr, Command *cmdPtr,
  3815   3818   			    struct CompileEnv *envPtr);
  3816   3819   MODULE_SCOPE int	TclCompileStringLastCmd(Tcl_Interp *interp,
  3817   3820   			    Tcl_Parse *parsePtr, Command *cmdPtr,
  3818   3821   			    struct CompileEnv *envPtr);

Changes to generic/tclStringObj.c.

  3860   3860   }
  3861   3861   
  3862   3862   /*
  3863   3863    *---------------------------------------------------------------------------
  3864   3864    *
  3865   3865    * TclStringReplace --
  3866   3866    *
  3867         - *	Implements the inner engine of the [string replace] command.
         3867  + *	Implements the inner engine of the [string replace] and
         3868  + *	[string insert] commands.
  3868   3869    *
  3869   3870    *	The result is a concatenation of a prefix from objPtr, characters
  3870   3871    *	0 through first-1, the insertPtr string value, and a suffix from
  3871   3872    *	objPtr, characters from first + count to the end. The effect is as if
  3872   3873    *	the inner substring of characters first through first+count-1 are
  3873   3874    *	removed and replaced with insertPtr. If insertPtr is NULL, it is
  3874   3875    *	treated as an empty string. When passed the flag TCL_STRING_IN_PLACE,
................................................................................
  3907   3908   	} else {
  3908   3909   	    return Tcl_DuplicateObj(objPtr);
  3909   3910   	}
  3910   3911       }
  3911   3912   
  3912   3913       /*
  3913   3914        * The caller very likely had to call Tcl_GetCharLength() or similar
  3914         -     * to be able to process index values.  This means it is like that
         3915  +     * to be able to process index values.  This means it is likely that
  3915   3916        * objPtr is either a proper "bytearray" or a "string" or else it has
  3916   3917        * a known and short string rep.
  3917   3918        */
  3918   3919   
  3919   3920       if (TclIsPureByteArray(objPtr)) {
  3920   3921   	int numBytes;
  3921   3922   	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes);

Changes to tests/string.test.

    69     69       interp alias {} run {} try
    70     70       set constraints {}
    71     71   }
    72     72   
    73     73   
    74     74   test string-1.1.$noComp {error conditions} {
    75     75       list [catch {run {string gorp a b}} msg] $msg
    76         -} {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}}
           76  +} {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}}
    77     77   test string-1.2.$noComp {error conditions} {
    78     78       list [catch {run {string}} msg] $msg
    79     79   } {1 {wrong # args: should be "string subcommand ?arg ...?"}}
    80     80   test stringComp-1.3.$noComp {error condition - undefined method during compile} {
    81     81       # We don't want this to complain about 'never' because it may never
    82     82       # be called, or string may get redefined.  This must compile OK.
    83     83       proc foo {str i} {
................................................................................
  1796   1796   } \u1361ABC
  1797   1797   
  1798   1798   test string-20.1.$noComp {string trimright errors} {
  1799   1799       list [catch {run {string trimright}} msg] $msg
  1800   1800   } {1 {wrong # args: should be "string trimright string ?chars?"}}
  1801   1801   test string-20.2.$noComp {string trimright errors} {
  1802   1802       list [catch {run {string trimg a}} msg] $msg
  1803         -} {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}}
         1803  +} {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}}
  1804   1804   test string-20.3.$noComp {string trimright} {
  1805   1805       run {string trimright "    XYZ      "}
  1806   1806   } {    XYZ}
  1807   1807   test string-20.4.$noComp {string trimright} {
  1808   1808       run {string trimright "   "}
  1809   1809   } {}
  1810   1810   test string-20.5.$noComp {string trimright} {
................................................................................
  1855   1855   } 3
  1856   1856   test string-21.14.$noComp {string wordend, unicode} {
  1857   1857       run {string wordend "\uc700\uc700 abc" 8}
  1858   1858   } 6
  1859   1859   
  1860   1860   test string-22.1.$noComp {string wordstart} {
  1861   1861       list [catch {run {string word a}} msg] $msg
  1862         -} {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}}
         1862  +} {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}}
  1863   1863   test string-22.2.$noComp {string wordstart} {
  1864   1864       list [catch {run {string wordstart a}} msg] $msg
  1865   1865   } {1 {wrong # args: should be "string wordstart string index"}}
  1866   1866   test string-22.3.$noComp {string wordstart} {
  1867   1867       list [catch {run {string wordstart a b c}} msg] $msg
  1868   1868   } {1 {wrong # args: should be "string wordstart string index"}}
  1869   1869   test string-22.4.$noComp {string wordstart} {
................................................................................
  2327   2327   
  2328   2328   test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} {
  2329   2329       run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]}
  2330   2330   } hellohello
  2331   2331   test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} {
  2332   2332       run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"}
  2333   2333   } hellohello
         2334  +
         2335  +# Note: string-31.* tests use [tcl::string::insert] rather than [string insert]
         2336  +# to dodge ticket [3397978fff] which would cause all arguments to be shared,
         2337  +# thereby preventing the optimizations from being tested.
         2338  +test string-31.1.$noComp {string insert, start of string} {
         2339  +    run {tcl::string::insert 0123 0 _}
         2340  +} _0123
         2341  +test string-31.2.$noComp {string insert, middle of string} {
         2342  +    run {tcl::string::insert 0123 2 _}
         2343  +} 01_23
         2344  +test string-31.3.$noComp {string insert, end of string} {
         2345  +    run {tcl::string::insert 0123 4 _}
         2346  +} 0123_
         2347  +test string-31.4.$noComp {string insert, start of string, end-relative} {
         2348  +    run {tcl::string::insert 0123 end-4 _}
         2349  +} _0123
         2350  +test string-31.5.$noComp {string insert, middle of string, end-relative} {
         2351  +    run {tcl::string::insert 0123 end-2 _}
         2352  +} 01_23
         2353  +test string-31.6.$noComp {string insert, end of string, end-relative} {
         2354  +    run {tcl::string::insert 0123 end _}
         2355  +} 0123_
         2356  +test string-31.7.$noComp {string insert, empty target string} {
         2357  +    run {tcl::string::insert {} 0 _}
         2358  +} _
         2359  +test string-31.8.$noComp {string insert, empty insert string} {
         2360  +    run {tcl::string::insert 0123 0 {}}
         2361  +} 0123
         2362  +test string-31.9.$noComp {string insert, empty strings} {
         2363  +    run {tcl::string::insert {} 0 {}}
         2364  +} {}
         2365  +test string-31.10.$noComp {string insert, negative index} {
         2366  +    run {tcl::string::insert 0123 -1 _}
         2367  +} _0123
         2368  +test string-31.11.$noComp {string insert, index beyond end} {
         2369  +    run {tcl::string::insert 0123 5 _}
         2370  +} 0123_
         2371  +test string-31.12.$noComp {string insert, start of string, pure byte array} {
         2372  +    run {tcl::string::insert [makeByteArray 0123] 0 [makeByteArray _]}
         2373  +} _0123
         2374  +test string-31.13.$noComp {string insert, middle of string, pure byte array} {
         2375  +    run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]}
         2376  +} 01_23
         2377  +test string-31.14.$noComp {string insert, end of string, pure byte array} {
         2378  +    run {tcl::string::insert [makeByteArray 0123] 4 [makeByteArray _]}
         2379  +} 0123_
         2380  +test string-31.15.$noComp {string insert, pure byte array, neither shared} {
         2381  +    run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]}
         2382  +} 01_23
         2383  +test string-31.16.$noComp {string insert, pure byte array, first shared} {
         2384  +    run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\
         2385  +            [makeByteArray _]}
         2386  +} 01_23
         2387  +test string-31.17.$noComp {string insert, pure byte array, second shared} {
         2388  +    run {tcl::string::insert [makeByteArray 0123] 2\
         2389  +            [makeShared [makeByteArray _]]}
         2390  +} 01_23
         2391  +test string-31.18.$noComp {string insert, pure byte array, both shared} {
         2392  +    run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\
         2393  +            [makeShared [makeByteArray _]]}
         2394  +} 01_23
         2395  +test string-31.19.$noComp {string insert, start of string, pure Unicode} {
         2396  +    run {tcl::string::insert [makeUnicode 0123] 0 [makeUnicode _]}
         2397  +} _0123
         2398  +test string-31.20.$noComp {string insert, middle of string, pure Unicode} {
         2399  +    run {tcl::string::insert [makeUnicode 0123] 2 [makeUnicode _]}
         2400  +} 01_23
         2401  +test string-31.21.$noComp {string insert, end of string, pure Unicode} {
         2402  +    run {tcl::string::insert [makeUnicode 0123] 4 [makeUnicode _]}
         2403  +} 0123_
         2404  +test string-31.22.$noComp {string insert, str start, pure Uni, first shared} {
         2405  +    run {tcl::string::insert [makeShared [makeUnicode 0123]] 0 [makeUnicode _]}
         2406  +} _0123
         2407  +test string-31.23.$noComp {string insert, string mid, pure Uni, 2nd shared} {
         2408  +    run {tcl::string::insert [makeUnicode 0123] 2 [makeShared [makeUnicode _]]}
         2409  +} 01_23
         2410  +test string-31.24.$noComp {string insert, string end, pure Uni, both shared} {
         2411  +    run {tcl::string::insert [makeShared [makeUnicode 0123]] 4\
         2412  +            [makeShared [makeUnicode _]]}
         2413  +} 0123_
         2414  +test string-31.25.$noComp {string insert, neither byte array nor Unicode} {
         2415  +    run {tcl::string::insert [makeList a b c] 1 zzzzzz}
         2416  +} {azzzzzz b c}
  2334   2417   
  2335   2418   test string-31.1.$noComp {string is dict} {
  2336   2419       string is dict {a b c d}
  2337   2420   } 1
  2338   2421   test string-31.1a.$noComp {string is dict} {
  2339   2422       string is dict {a b c}
  2340   2423   } 0