Author: coke
Date: Thu Dec 29 11:29:25 2005
New Revision: 10774
Modified:
trunk/languages/tcl/lib/commands/string.pir
trunk/languages/tcl/t/cmd_string.t
Log:
#38066: [PATCH] TCL [string totitle] TCH] tcl [string trim(left|right|)
Courtesy Albert Simoes <[EMAIL PROTECTED]>
Modified: trunk/languages/tcl/lib/commands/string.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/string.pir (original)
+++ trunk/languages/tcl/lib/commands/string.pir Thu Dec 29 11:29:25 2005
@@ -192,6 +192,7 @@ bad_args:
+
.sub "toupper"
.param pmc argv
@@ -713,3 +714,123 @@ bad_args:
.throw('wrong # args: should be "string is class ?-strict? ?-failindex var?
str"')
.end
+
+
+.sub "trimleft"
+ .param pmc argv
+
+ .local int argc
+ .local pmc retval
+
+ argc = argv
+ if argc > 2 goto bad_args
+ if argc < 1 goto bad_args
+
+ $S1 = argv[0]
+ $S2 = " \t\r\n"
+
+ if argc == 1 goto trimleft_do
+
+ $S2 = argv[1]
+
+trimleft_do:
+ .local string char
+
+ char = substr $S1, 0, 1
+ $I1 = index $S2, char
+
+ if $I1 < 0 goto trimleft_done
+ substr $S1, 0, 1, ""
+ goto trimleft_do
+
+trimleft_done:
+ .return($S1)
+
+bad_args:
+ .throw ("wrong # args: should be \"string trimleft string ?chars?\"")
+
+.end
+
+
+
+.sub "trimright"
+ .param pmc argv
+
+ .local int argc
+ .local pmc retval
+
+ argc = argv
+ if argc > 2 goto bad_args
+ if argc < 1 goto bad_args
+
+ $S1 = argv[0]
+ $S2 = " \t\r\n"
+
+ if argc == 1 goto trimright_do
+
+ $S2 = argv[1]
+
+trimright_do:
+ .local string char
+
+ char = substr $S1, -1, 1
+ $I1 = index $S2, char
+
+ if $I1 < 0 goto trimright_done
+ chopn $S1, 1
+ goto trimright_do
+
+trimright_done:
+ .return($S1)
+
+bad_args:
+ .throw ("wrong # args: should be \"string trimright string ?chars?\"")
+
+.end
+
+# here, I might use trimleft and trim right, but I think it is
+# better to implement it here as it should be faster
+
+.sub "trim"
+ .param pmc argv
+
+ .local int argc
+ .local pmc retval
+
+ argc = argv
+ if argc > 2 goto bad_args
+ if argc < 1 goto bad_args
+
+ $S1 = argv[0]
+ $S2 = " \t\r\n"
+
+ if argc == 1 goto trim_do1
+
+ $S2 = argv[1]
+
+trim_do1:
+ .local string char
+
+ char = substr $S1, -1, 1
+ $I1 = index $S2, char
+
+ if $I1 < 0 goto trim_do2
+ chopn $S1, 1
+ goto trim_do1
+
+trim_do2:
+ char = substr $S1, 0, 1
+ $I1 = index $S2, char
+
+ if $I1 < 0 goto trim_done
+ substr $S1, 0, 1, ""
+ goto trim_do2
+
+trim_done:
+ .return($S1)
+
+bad_args:
+ .throw ("wrong # args: should be \"string trim string ?chars?\"")
+
+.end
+
Modified: trunk/languages/tcl/t/cmd_string.t
==============================================================================
--- trunk/languages/tcl/t/cmd_string.t (original)
+++ trunk/languages/tcl/t/cmd_string.t Thu Dec 29 11:29:25 2005
@@ -2,7 +2,7 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 97;
+use Parrot::Test tests => 109;
use Parrot::Config;
use Test::More;
@@ -551,6 +551,86 @@ PARROT
OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string trimleft, bad args");
+ string trimleft
+TCL
+wrong # args: should be "string trimleft string ?chars?"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string trimleft, no chars");
+ puts [string trimleft " \nfoo"]
+TCL
+foo
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string trimleft, char set");
+ puts [string trimleft "abcfaoo" abc]
+TCL
+faoo
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string trimleft, char set, no match");
+ puts [string trimleft "abcfaoo" z]
+TCL
+abcfaoo
+OUT
+
+
+
+language_output_is("tcl",<<'TCL',<<OUT,"string trimright, bad args");
+ string trimright
+TCL
+wrong # args: should be "string trimright string ?chars?"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string trimright, no chars");
+ puts [string trimright " foo "]
+TCL
+ foo
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string trimright, char set");
+ puts [string trimright "abcfaoo" ao]
+TCL
+abcf
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string trimright, char set, no match");
+ puts [string trimright "abcfaoo" z]
+TCL
+abcfaoo
+OUT
+
+
+
+
+
+language_output_is("tcl",<<'TCL',<<OUT,"string trim, bad args");
+ string trim
+TCL
+wrong # args: should be "string trim string ?chars?"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string trim, no chars");
+ puts [string trim " \n foo "]
+TCL
+foo
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string trim, char set");
+ puts [string trim "ooabacfaoo" ao]
+TCL
+bacf
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string trim, char set, no match");
+ puts [string trim "abcfaoo" z]
+TCL
+abcfaoo
+OUT
+
+
# XXX - many of the classes are NOT tested here, and we rely
# on the cvs tests from tcl for that.
