# 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