# New Ticket Created by Alberto Simoes
# Please include the string: [perl #38066]
# in the subject line of all future correspondence about this issue.
# <URL: https://rt.perl.org/rt3/Ticket/Display.html?id=38066 >
--
Alberto Simões - Departamento de Informática - Universidade do Minho
Campus de Gualtar - 4710-057 Braga - Portugal
Index: languages/tcl/t/cmd_string.t
===================================================================
--- languages/tcl/t/cmd_string.t (revision 10767)
+++ languages/tcl/t/cmd_string.t (working copy)
@@ -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 @@
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.
Index: languages/tcl/lib/commands/string.pir
===================================================================
--- languages/tcl/lib/commands/string.pir (revision 10767)
+++ languages/tcl/lib/commands/string.pir (working copy)
@@ -192,6 +192,7 @@
+
.sub "toupper"
.param pmc argv
@@ -713,3 +714,123 @@
.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
+
