Author: coke
Date: Thu Dec 29 11:52:50 2005
New Revision: 10776
Modified:
trunk/languages/tcl/lib/commands/string.pir
trunk/languages/tcl/t/cmd_string.t
Log:
#38067: [PATCH] tcl [string replace] working
Courtesy Alberto 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:52:50 2005
@@ -712,7 +712,58 @@ nope:
bad_args:
.throw('wrong # args: should be "string is class ?-strict? ?-failindex var?
str"')
+.end
+
+
+.sub "replace"
+ .param pmc argv
+
+ .local int argc
+ .local int low
+ .local int high
+ .local int len
+ .local pmc retval
+ .local pmc string_index
+ string_index = find_global "_Tcl", "__string_index"
+
+ argc = argv
+ if argc > 4 goto bad_args
+ if argc < 3 goto bad_args
+
+ $S1 = argv[0]
+ $S4 = ""
+
+ $S2 = argv[1]
+ low = string_index($S2, $S1)
+
+ $S3 = argv[2]
+ high = string_index($S3, $S1)
+
+ if high < low goto replace_done
+
+ if low >= 0 goto low_ok
+ low = 0
+
+low_ok:
+ len = length $S1
+ if high <= len goto high_ok
+ high = len
+
+high_ok:
+ if argc == 1 goto replace_do
+ $S4 = argv[3]
+
+replace_do:
+ len = high - low
+ len += 1
+ substr $S1, low, len, $S4
+
+replace_done:
+ .return($S1)
+
+bad_args:
+ .throw ("wrong # args: should be \"string replace string first last
?string?\"")
.end
@@ -834,3 +885,4 @@ bad_args:
.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:52:50 2005
@@ -2,7 +2,8 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 109;
+
+use Parrot::Test tests => 115;
use Parrot::Config;
use Test::More;
@@ -551,6 +552,42 @@ PARROT
OUT
+language_output_is("tcl",<<'TCL',<<OUT,"string replace, bad args");
+ string replace
+TCL
+wrong # args: should be "string replace string first last ?string?"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string replace, simple");
+ puts [string replace parrcamelot 4 8]
+TCL
+parrot
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string replace, negative index");
+ puts [string replace junkparrot -10 3]
+TCL
+parrot
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string replace, index bigger than
string");
+ puts [string replace parrotjunk 6 20]
+TCL
+parrot
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string replace, by something");
+ puts [string replace perl 1 3 arrot]
+TCL
+parrot
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string replace, swapped indexes");
+ puts [string replace perl 3 1 arrot]
+TCL
+perl
+OUT
+
language_output_is("tcl",<<'TCL',<<OUT,"string trimleft, bad args");
string trimleft
@@ -630,7 +667,6 @@ TCL
abcfaoo
OUT
-
# XXX - many of the classes are NOT tested here, and we rely
# on the cvs tests from tcl for that.
