# New Ticket Created by Alberto Simoes
# Please include the string: [perl #38072]
# in the subject line of all future correspondence about this issue.
# <URL: https://rt.perl.org/rt3/Ticket/Display.html?id=38072 >
Note that this patch does not fixes the failing tests added by Coke on
last commit, as I'm not sure I agree with his changes.
--
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 10785)
+++ languages/tcl/t/cmd_string.t (working copy)
@@ -3,10 +3,11 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
-use Parrot::Test tests => 115;
+use Parrot::Test tests => 133;
use Parrot::Config;
use Test::More;
+
language_output_is("tcl",<<TCL,<<OUT,"first, initial");
string
TCL
@@ -690,3 +691,115 @@
OUT
}
+
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, bad args (1)");
+ string compare
+TCL
+wrong # args: should be "string compare ?-nocase? ?-length int? string1
string2"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, bad args (2)");
+ string compare -length "aaa" "bbb"
+TCL
+wrong # args: should be "string compare ?-nocase? ?-length int? string1
string2"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, bad args (3)");
+ string compare -length 4 -length 8 "aaa" "bbb"
+TCL
+wrong # args: should be "string compare ?-nocase? ?-length int? string1
string2"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, same string");
+ puts [string compare aaa aaa]
+TCL
+0
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, \"lower\" string");
+ puts [string compare aaa aab]
+TCL
+-1
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, \"higher\" string");
+ puts [string compare aab aaa]
+TCL
+1
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, bigger string");
+ puts [string compare aaaa aaa]
+TCL
+1
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, smaller string");
+ puts [string compare aaa aaaa]
+TCL
+-1
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, different sizes, len
specified");
+ puts [string compare -length 3 aaa aaaa]
+TCL
+0
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, different strings, len
specified");
+ puts [string compare -length 4 aaabc aaabb]
+TCL
+0
+OUT
+
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, same string, different
case");
+ puts [string compare -nocase AAA aaa]
+TCL
+0
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, \"lower\" string,
different case");
+ puts [string compare -nocase aaa AAB]
+TCL
+-1
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, \"higher\" string,
different case");
+ puts [string compare -nocase AAB aaa]
+TCL
+1
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, bigger string,
different case");
+ puts [string compare -nocase AAAA aaa]
+TCL
+1
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, smaller string,
different case");
+ puts [string compare -nocase AAA aaaa]
+TCL
+-1
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, different sizes, len
specified, different case");
+ puts [string compare -length 3 -nocase aaa AAAA]
+TCL
+0
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, different strings, len
specified, different case");
+ puts [string compare -length 4 -nocase AAABC aaabb]
+TCL
+0
+OUT
+
+
+language_output_is("tcl",<<'TCL',<<OUT,"string compare, same string, different
case");
+ puts [string compare AAAA aaaa]
+TCL
+-1
+OUT
+
Index: languages/tcl/lib/commands/string.pir
===================================================================
--- languages/tcl/lib/commands/string.pir (revision 10785)
+++ languages/tcl/lib/commands/string.pir (working copy)
@@ -886,3 +886,60 @@
.end
+
+.sub "compare"
+ .param pmc argv
+
+ .local int argc
+ .local pmc retval
+ .local int size
+
+ size = -1
+ argc = argv
+
+ if argc < 1 goto bad_args
+
+ $S2 = pop argv
+ $S1 = pop argv
+
+args_processment:
+ argc = argv
+ if argc == 0 goto args_processed
+ $S4 = shift argv
+ if $S4 == "-nocase" goto arg_nocase
+ if $S4 == "-length" goto arg_length
+ goto bad_args
+
+args_processed:
+ if $S1 == $S2 goto equal
+ if $S1 < $S2 goto smaller
+ .return(1)
+
+smaller:
+ .return(-1)
+
+equal:
+ .return(0)
+
+arg_nocase:
+ downcase $S1
+ downcase $S2
+ goto args_processment
+
+arg_length:
+ if size != -1 goto bad_args
+ argc = argv
+ if argc == 0 goto bad_args
+ $S4 = shift argv
+ ### TODO:
+ ### Here I should check that $S4 is really an integer
+ ### and if not, say something like: expected integer but got "5.4"
+ size = $S4
+ $S1 = substr $S1, 0, size
+ $S2 = substr $S2, 0, size
+ goto args_processment
+
+bad_args:
+ .throw ("wrong # args: should be \"string compare ?-nocase? ?-length int?
string1 string2\"")
+
+.end
