Tcl Source Code

Check-in [04d41e57ba]
Login
Bounty program for improvements to Tcl and certain Tcl packages.

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

Overview
Comment:New "string" subcommands: "nextchar", "nextword", "prevchar", "prevword". Not implemented yet (for now same as "wordstart"/"wordend"). Deprecate "string bytelength".
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-575
Files: files | file ages | folders
SHA3-256: 04d41e57ba43b86e764c673cdf2766d0b3aa1d51e52c79e7e9c7e78027007e25
User & Date: jan.nijtmans 2020-05-22 15:27:43
Context
2020-05-22
21:28
Split more "string" functions. New helper function TclUniCharToUCS4(), not used yet but that's the n... check-in: ec03d6f62d user: jan.nijtmans tags: tip-575
15:27
New "string" subcommands: "nextchar", "nextword", "prevchar", "prevword". Not implemented yet (for n... check-in: 04d41e57ba user: jan.nijtmans tags: tip-575
14:36
Merge 8.7 Add function Tcl_UniCharFold(). It's the same as Tcl_UniCharToLower() for now, but that wi... check-in: c338858460 user: jan.nijtmans tags: tip-575
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclCmdMZ.c.

2827
2828
2829
2830
2831
2832
2833

2834
2835
2836
2837
2838
2839
2840
....
2845
2846
2847
2848
2849
2850
2851

2852
2853
2854
2855
2856
2857
2858
....
3301
3302
3303
3304
3305
3306
3307

3308

3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319




3320
3321
3322
3323
3324
3325
3326
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
StringBytesCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
................................................................................
	return TCL_ERROR;
    }

    (void) TclGetStringFromObj(objv[1], &length);
    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length));
    return TCL_OK;
}

 
/*
 *----------------------------------------------------------------------
 *
 * StringLenCmd --
 *
 *	This procedure is invoked to process the "string length" Tcl command.
................................................................................
 */

Tcl_Command
TclInitStringCmd(
    Tcl_Interp *interp)		/* Current interpreter. */
{
    static const EnsembleImplMap stringImplMap[] = {

	{"bytelength",	StringBytesCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},

	{"cat",		StringCatCmd,	TclCompileStringCatCmd, NULL, NULL, 0},
	{"compare",	StringCmpCmd,	TclCompileStringCmpCmd, NULL, NULL, 0},
	{"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},
	{"map",		StringMapCmd,	TclCompileStringMapCmd, NULL, NULL, 0},
	{"match",	StringMatchCmd,	TclCompileStringMatchCmd, NULL, NULL, 0},




	{"range",	StringRangeCmd,	TclCompileStringRangeCmd, NULL, NULL, 0},
	{"repeat",	StringReptCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"replace",	StringRplcCmd,	TclCompileStringReplaceCmd, NULL, NULL, 0},
	{"reverse",	StringRevCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
	{"tolower",	StringLowerCmd,	TclCompileStringToLowerCmd, NULL, NULL, 0},
	{"toupper",	StringUpperCmd,	TclCompileStringToUpperCmd, NULL, NULL, 0},
	{"totitle",	StringTitleCmd,	TclCompileStringToTitleCmd, NULL, NULL, 0},







>







 







>







 







>

>











>
>
>
>







2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
....
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
....
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
static int
StringBytesCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
................................................................................
	return TCL_ERROR;
    }

    (void) TclGetStringFromObj(objv[1], &length);
    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length));
    return TCL_OK;
}
#endif
 
/*
 *----------------------------------------------------------------------
 *
 * StringLenCmd --
 *
 *	This procedure is invoked to process the "string length" Tcl command.
................................................................................
 */

Tcl_Command
TclInitStringCmd(
    Tcl_Interp *interp)		/* Current interpreter. */
{
    static const EnsembleImplMap stringImplMap[] = {
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
	{"bytelength",	StringBytesCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
#endif
	{"cat",		StringCatCmd,	TclCompileStringCatCmd, NULL, NULL, 0},
	{"compare",	StringCmpCmd,	TclCompileStringCmpCmd, NULL, NULL, 0},
	{"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},
	{"map",		StringMapCmd,	TclCompileStringMapCmd, NULL, NULL, 0},
	{"match",	StringMatchCmd,	TclCompileStringMatchCmd, NULL, NULL, 0},
	{"nextchar",	StringEndCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"nextword",	StringEndCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"prevchar",	StringStartCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"prevword",	StringStartCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"range",	StringRangeCmd,	TclCompileStringRangeCmd, NULL, NULL, 0},
	{"repeat",	StringReptCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"replace",	StringRplcCmd,	TclCompileStringReplaceCmd, NULL, NULL, 0},
	{"reverse",	StringRevCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
	{"tolower",	StringLowerCmd,	TclCompileStringToLowerCmd, NULL, NULL, 0},
	{"toupper",	StringUpperCmd,	TclCompileStringToUpperCmd, NULL, NULL, 0},
	{"totitle",	StringTitleCmd,	TclCompileStringToTitleCmd, NULL, NULL, 0},

Changes to tests/info.test.

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
    eval [info body foo]
} -returnCodes error -result {can't read "args": no such variable}
# Fix for problem tested for in info-2.5 caused problems when
# procedure body had no string rep (i.e. was not yet bytecode)
# causing an empty string to be returned [Bug #545644]
test info-2.6 {info body option, returning list bodies} {
    proc foo args [list subst bar]
    list [string bytelength [info body foo]] \
	    [foo; string bytelength [info body foo]]
} {9 9}

proc testinfocmdcount {} {
    set x [info cmdcount]
    set y 12345
    set z [info cmdc]
    expr {$z-$x}







|
|







99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
    eval [info body foo]
} -returnCodes error -result {can't read "args": no such variable}
# Fix for problem tested for in info-2.5 caused problems when
# procedure body had no string rep (i.e. was not yet bytecode)
# causing an empty string to be returned [Bug #545644]
test info-2.6 {info body option, returning list bodies} {
    proc foo args [list subst bar]
    list [string length [info body foo]] \
	    [foo; string length [info body foo]]
} {9 9}

proc testinfocmdcount {} {
    set x [info cmdcount]
    set y 12345
    set z [info cmdc]
    expr {$z-$x}

Changes to tests/regexp.test.

756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771

test regexp-20.1 {regsub shared object shimmering} -body {
    # Bug #461322
    set a abcdefghijklmnopqurstuvwxyz
    set b $a
    set c abcdefghijklmnopqurstuvwxyz0123456789
    regsub $a $c $b d
    list $d [string length $d] [string bytelength $d]
} -result [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
test regexp-20.2 {regsub shared object shimmering with -about} -body {
    eval regexp -about abc
} -result {0 {}}

test regexp-21.1 {regsub works with empty string} -body {
    regsub -- ^ {} foo
} -result {foo}







|
|







756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771

test regexp-20.1 {regsub shared object shimmering} -body {
    # Bug #461322
    set a abcdefghijklmnopqurstuvwxyz
    set b $a
    set c abcdefghijklmnopqurstuvwxyz0123456789
    regsub $a $c $b d
    list $d [string length $d]
} -result [list abcdefghijklmnopqurstuvwxyz0123456789 37]
test regexp-20.2 {regsub shared object shimmering with -about} -body {
    eval regexp -about abc
} -result {0 {}}

test regexp-21.1 {regsub works with empty string} -body {
    regsub -- ^ {} foo
} -result {foo}

Changes to tests/regexpComp.test.

794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
test regexpComp-20.1 {regsub shared object shimmering} {
    evalInProc {
	# Bug #461322
	set a abcdefghijklmnopqurstuvwxyz
	set b $a
	set c abcdefghijklmnopqurstuvwxyz0123456789
	regsub $a $c $b d
	list $d [string length $d] [string bytelength $d]
    }
} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
test regexpComp-20.2 {regsub shared object shimmering with -about} {
    evalInProc {
	eval regexp -about abc
    }
} {0 {}}

test regexpComp-21.1 {regexp command compiling tests} {







|

|







794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
test regexpComp-20.1 {regsub shared object shimmering} {
    evalInProc {
	# Bug #461322
	set a abcdefghijklmnopqurstuvwxyz
	set b $a
	set c abcdefghijklmnopqurstuvwxyz0123456789
	regsub $a $c $b d
	list $d [string length $d]
    }
} [list abcdefghijklmnopqurstuvwxyz0123456789 37]
test regexpComp-20.2 {regsub shared object shimmering with -about} {
    evalInProc {
	eval regexp -about abc
    }
} {0 {}}

test regexpComp-21.1 {regexp command compiling tests} {

Changes to tests/string.test.

29
30
31
32
33
34
35

36
37
38
39
40
41
42
..
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
....
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
....
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
....
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
# Some tests require the testobj command

testConstraint testobj [expr {[info commands testobj] ne {}}]
testConstraint testindexobj [expr {[info commands testindexobj] ne {}}]
testConstraint testevalex [expr {[info commands testevalex] ne {}}]
testConstraint utf16 [expr {[string length \U010000] == 2}]
testConstraint testbytestring   [llength [info commands testbytestring]]


# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc getbytes {} {
        set lines [split [memory info] \n]
        return [lindex $lines 3 3]
................................................................................
    set constraints testevalex
} else {
    interp alias {} run {} try
    set constraints {}
}

 
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, 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 ...?"}}
test stringComp-1.3.$noComp {error condition - undefined method during compile} {
    # We don't want this to complain about 'never' because it may never
    # be called, or string may get redefined.  This must compile OK.
    proc foo {str i} {
................................................................................
test string-7.15.$noComp {string last, start index} {
    run {string last \334a \334ad\334ad 0}
} -1
test string-7.16.$noComp {string last, start index} {
    run {string last \334a \334ad\334ad end-1}
} 3

test string-8.1.$noComp {string bytelength} {
    list [catch {run {string bytelength}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.2.$noComp {string bytelength} {
    list [catch {run {string bytelength a b}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.3.$noComp {string bytelength} {
    run {string bytelength "\xC7"}
} 2
test string-8.4.$noComp {string bytelength} {
    run {string b ""}
} 0

test string-9.1.$noComp {string length} {
    list [catch {run {string length}} msg] $msg
} {1 {wrong # args: should be "string length string"}}
test string-9.2.$noComp {string length} {
................................................................................
test string-19.3.$noComp {string trimleft, unicode default} {
    run {string trimleft \uFEFF\x85\xA0\x00\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000\u1361ABC}
} \u1361ABC

test string-20.1.$noComp {string trimright errors} {
    list [catch {run {string trimright}} msg] $msg
} {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, 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}
test string-20.4.$noComp {string trimright} {
    run {string trimright "   "}
} {}
test string-20.5.$noComp {string trimright} {
................................................................................
} -result 2
test string-21.16.$noComp {string wordend, unicode} -constraints utf16 -body {
    run {string wordend "\U1D7CA\U1D7CA abc" 10}
} -result 8

test string-22.1.$noComp {string wordstart} -body {
    list [catch {run {string word a}} msg] $msg
} -result {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} -body {
    list [catch {run {string wordstart a}} msg] $msg
} -result {1 {wrong # args: should be "string wordstart string index"}}
test string-22.3.$noComp {string wordstart} -body {
    list [catch {run {string wordstart a b c}} msg] $msg
} -result {1 {wrong # args: should be "string wordstart string index"}}
test string-22.4.$noComp {string wordstart} -body {







>







 







|

|







 







|


|


|


|







 







|

|







 







|







29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
..
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
....
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
....
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
....
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
# Some tests require the testobj command

testConstraint testobj [expr {[info commands testobj] ne {}}]
testConstraint testindexobj [expr {[info commands testindexobj] ne {}}]
testConstraint testevalex [expr {[info commands testevalex] ne {}}]
testConstraint utf16 [expr {[string length \U010000] == 2}]
testConstraint testbytestring   [llength [info commands testbytestring]]
testConstraint nodep [info exists tcl_precision]

# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc getbytes {} {
        set lines [split [memory info] \n]
        return [lindex $lines 3 3]
................................................................................
    set constraints testevalex
} else {
    interp alias {} run {} try
    set constraints {}
}

 
test string-1.1.$noComp {error conditions} -body {
    list [catch {run {string gorp a b}} msg] $msg
} -match regexp -result {1 {unknown or ambiguous subcommand "gorp": must be (bytelength, |)cat, compare, equal, first, index, insert, is, last, length, map, match, nextchar, nextword, prevchar, prevword, 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 ...?"}}
test stringComp-1.3.$noComp {error condition - undefined method during compile} {
    # We don't want this to complain about 'never' because it may never
    # be called, or string may get redefined.  This must compile OK.
    proc foo {str i} {
................................................................................
test string-7.15.$noComp {string last, start index} {
    run {string last \334a \334ad\334ad 0}
} -1
test string-7.16.$noComp {string last, start index} {
    run {string last \334a \334ad\334ad end-1}
} 3

test string-8.1.$noComp {string bytelength} nodep {
    list [catch {run {string bytelength}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.2.$noComp {string bytelength} nodep {
    list [catch {run {string bytelength a b}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.3.$noComp {string bytelength} nodep {
    run {string bytelength "\xC7"}
} 2
test string-8.4.$noComp {string bytelength} nodep {
    run {string b ""}
} 0

test string-9.1.$noComp {string length} {
    list [catch {run {string length}} msg] $msg
} {1 {wrong # args: should be "string length string"}}
test string-9.2.$noComp {string length} {
................................................................................
test string-19.3.$noComp {string trimleft, unicode default} {
    run {string trimleft \uFEFF\x85\xA0\x00\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000\u1361ABC}
} \u1361ABC

test string-20.1.$noComp {string trimright errors} {
    list [catch {run {string trimright}} msg] $msg
} {1 {wrong # args: should be "string trimright string ?chars?"}}
test string-20.2.$noComp {string trimright errors} -body {
    list [catch {run {string trimg a}} msg] $msg
} -match regexp -result {1 {unknown or ambiguous subcommand "trimg": must be (bytelength, |)cat, compare, equal, first, index, insert, is, last, length, map, match, nextchar, nextword, prevchar, prevword, 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}
test string-20.4.$noComp {string trimright} {
    run {string trimright "   "}
} {}
test string-20.5.$noComp {string trimright} {
................................................................................
} -result 2
test string-21.16.$noComp {string wordend, unicode} -constraints utf16 -body {
    run {string wordend "\U1D7CA\U1D7CA abc" 10}
} -result 8

test string-22.1.$noComp {string wordstart} -body {
    list [catch {run {string word a}} msg] $msg
} -match regexp -result {1 {unknown or ambiguous subcommand "word": must be (bytelength, |)cat, compare, equal, first, index, insert, is, last, length, map, match, nextchar, nextword, prevchar, prevword, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2.$noComp {string wordstart} -body {
    list [catch {run {string wordstart a}} msg] $msg
} -result {1 {wrong # args: should be "string wordstart string index"}}
test string-22.3.$noComp {string wordstart} -body {
    list [catch {run {string wordstart a b c}} msg] $msg
} -result {1 {wrong # args: should be "string wordstart string index"}}
test string-22.4.$noComp {string wordstart} -body {