Author: coke
Date: Thu Dec 29 10:09:00 2005
New Revision: 10767
Modified:
trunk/languages/tcl/lib/commands/string.pir
trunk/languages/tcl/t/cmd_string.t
Log:
#38065: [PATCH] TCL [string totitle]
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 10:09:00 2005
@@ -243,6 +243,59 @@ bad_args:
.end
+
+.sub "totitle"
+ .param pmc argv
+
+ .local int argc
+ .local pmc retval
+
+ argc = argv
+ if argc > 3 goto bad_args
+ if argc < 1 goto bad_args
+
+ $S1 = argv[0]
+ $I1 = length $S1 # it will be useful
+
+ # If no range is specified, do to all the string
+ $I2 = 0
+ $I3 = $I1
+ if argc == 1 goto totitle_do
+
+ .local pmc string_index
+ string_index = find_global "_Tcl", "__string_index"
+
+ $S2 = argv[1]
+ $I2 = string_index($S2, $S1)
+ # if just the first is specified, the last is the same (tclsh says so)
+ $I3 = $I2
+ if argc == 2 goto totitle_do
+
+ $S3 = argv[2]
+ $I3 = string_index($S3, $S1)
+
+totitle_do:
+ if $I2 > $I1 goto totitle_return
+ if $I3 <= $I1 goto totitle_start
+ $I3 = $I1
+
+totitle_start:
+ $I4 = $I3 - $I2
+ $I4+= 1
+ $S2 = substr $S1, $I2, $I4
+ titlecase $S2
+ substr $S1, $I2, $I4, $S2
+
+totitle_return:
+ .return($S1)
+
+bad_args:
+ .throw ("wrong # args: should be \"string totitle string ?first? ?last?\"")
+
+.end
+
+
+
.sub "bytelength"
.param pmc argv
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 10:09:00 2005
@@ -2,7 +2,7 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 92;
+use Parrot::Test tests => 97;
use Parrot::Config;
use Test::More;
@@ -519,6 +519,38 @@ parrot
OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string totitle, Simple");
+ puts [string totitle "AabcD ABC"]
+TCL
+Aabcd abc
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string totitle, bad args");
+ string totitle
+TCL
+wrong # args: should be "string totitle string ?first? ?last?"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string totitle, both limits");
+ puts [string totitle PARROT end-4 4]
+TCL
+PArroT
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string totitle, single index");
+ puts [string totitle parrot 4]
+TCL
+parrOt
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string totitle, single index, out of
string");
+ puts [string totitle PARROT 40]
+TCL
+PARROT
+OUT
+
+
# XXX - many of the classes are NOT tested here, and we rely
# on the cvs tests from tcl for that.
