[perl #38065] [PATCH] TCL [string totitle]

[via RT]

# New Ticket Created by  Alberto Simoes 
# Please include the string:  [perl #38065]
# in the subject line of all future correspondence about this issue. 
# <URL: https://rt.perl.org/rt3/Ticket/Display.html?id=38065 >


Cheers
Alberto
-- 
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 10763)
+++ 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 => 92;
+use Parrot::Test tests => 97;
 use Parrot::Config;
 use Test::More;
 
@@ -519,6 +519,38 @@
 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.
 
Index: languages/tcl/lib/commands/string.pir
===================================================================
--- languages/tcl/lib/commands/string.pir       (revision 10763)
+++ languages/tcl/lib/commands/string.pir       (working copy)
@@ -243,6 +243,59 @@
 .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