Fix label on C<for(;;)> statement

[p5sagit/p5-mst-13.2.git] / t / pragma / locale.t

diff --git a/t/pragma/locale.t b/t/pragma/locale.t
index 0f71da4..d4b73b8 100755 (executable)
--- a/t/pragma/locale.t
+++ b/t/pragma/locale.t
@@ -3,6 +3,11 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
+    require Config; import Config;
+    if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) {
+       print "1..0\n";
+       exit;
+    }
 }
 
 use strict;
@@ -14,7 +19,7 @@ eval {
     $have_setlocale++;
 };
 
-print "1..", ($have_setlocale ? 104 : 98), "\n";
+print "1..", ($have_setlocale ? 102 : 98), "\n";
 
 use vars qw($a
            $English $German $French $Spanish
@@ -35,6 +40,7 @@ sub ok {
 # even the default locale will taint under 'use locale'.
 
 sub is_tainted { # hello, camel two.
+    local $^W; # no warnings 'undef'
     my $dummy;
     not eval { $dummy = join("", @_), kill 0; 1 }
 }
@@ -313,32 +319,6 @@ for (@Locale) {
     }
 }
 
-# Cross-check the upper and the lower.
-# Yes, this is broken when the upper<->lower changes the number of
-# the glyphs (e.g. the German sharp-s aka double-s aka sz-ligature,
-# or the Dutch IJ or the Spanish LL or ...)
-# But so far all the implementations do this wrong so we can do it wrong too.
-
-for (keys %UPPER) {
-    if (defined $lower{$UPPER{$_}}) {
-       if ($_ ne $lower{$UPPER{$_}}) {
-           print 'not ';
-           last;
-       }
-    }
-}
-print "ok 99\n";
-
-for (keys %lower) {
-    if (defined $UPPER{$lower{$_}}) {
-       if ($_ ne $UPPER{$lower{$_}}) {
-           print 'not ';
-           last;
-       }
-    }
-}
-print "ok 100\n";
-
 # Find the alphabets that are not alphabets in the default locale.
 
 {
@@ -360,10 +340,11 @@ print "ok 100\n";
 
     print 'not ' if ($1 ne $word);
 }
-print "ok 101\n";
+print "ok 99\n";
 
 # Find places where the collation order differs from the default locale.
 
+print "# testing 100\n";
 {
     my (@k, $i, $j, @d);
 
@@ -386,6 +367,7 @@ print "ok 101\n";
     for (@d) {
        ($i, $j) = @$_;
        if ($i gt $j) {
+           print "# failed 100 at:\n";
            print "# i = $i, j = $j, i ",
                  $i le $j ? 'le' : 'gt', " j\n";
            print 'not ';
@@ -393,26 +375,30 @@ print "ok 101\n";
        }
     }
 }
-print "ok 102\n";
+print "ok 100\n";
 
 # Cross-check whole character set.
 
+print "# testing 101\n";
 for (map { chr } 0..255) {
     if (/\w/ and /\W/) { print 'not '; last }
     if (/\d/ and /\D/) { print 'not '; last }
     if (/\s/ and /\S/) { print 'not '; last }
     if (/\w/ and /\D/ and not /_/ and
        not (exists $UPPER{$_} or exists $lower{$_})) {
+       print "# failed 101 at:\n";
+       print "# ", ord($_), " '$_'\n";
        print 'not ';
        last;
     }
 }
-print "ok 103\n";
+print "ok 101\n";
 
 # The @Locale should be internally consistent.
 
+print "# testing 102\n";
 {
-    my ($from, $to, , $lesser, $greater);
+    my ($from, $to, $lesser, $greater, @test, %test, $test);
 
     for (0..9) {
        # Select a slice.
@@ -424,26 +410,45 @@ print "ok 103\n";
        $from++; $to++;
         $to = $#Locale if ($to > $#Locale);
        $greater = join('', @Locale[$from..$to]);
-       if (not ($lesser  lt $greater) or
-           not ($lesser  le $greater) or
-           not ($lesser  ne $greater) or
-               ($lesser  eq $greater) or
-               ($lesser  ge $greater) or
-               ($lesser  gt $greater) or
-               ($greater lt $lesser ) or
-               ($greater le $lesser ) or
-           not ($greater ne $lesser ) or
-               ($greater eq $lesser ) or
-           not ($greater ge $lesser ) or
-           not ($greater gt $lesser ) or
-           # Well, these two are sort of redundant because @Locale
-           # was derived using cmp.
-           not (($lesser  cmp $greater) == -1) or
-           not (($greater cmp $lesser ) ==  1)
-          ) {
+       @test = 
+           (
+            'not ($lesser  lt $greater)', # 0
+            'not ($lesser  le $greater)', # 1
+            'not ($lesser  ne $greater)', # 2
+            '    ($lesser  eq $greater)', # 3
+            '    ($lesser  ge $greater)', # 4
+            '    ($lesser  gt $greater)', # 5
+            '    ($greater lt $lesser )', # 6
+            '    ($greater le $lesser )', # 7
+            'not ($greater ne $lesser )', # 8
+            '    ($greater eq $lesser )', # 9
+            'not ($greater ge $lesser )', # 10
+            'not ($greater gt $lesser )', # 11
+            # Well, these two are sort of redundant
+            # because @Locale was derived using cmp.
+            'not (($lesser  cmp $greater) == -1)', # 12
+            'not (($greater cmp $lesser ) ==  1)'  # 13
+            );
+       @test{@test} = 0 x @test;
+       $test = 0;
+       for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} }
+       if ($test) {
+           print "# failed 102 at:\n";
+           print "# lesser  = '$lesser'\n";
+           print "# greater = '$greater'\n";
+           print "# (greater) from = $from, to = $to\n";
+           for my $ti (@test) {
+               printf("# %-40s %-4s", $ti,
+                      $test{$ti} ? 'FAIL' : 'ok');
+               if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
+                   printf("(%s == %4d)", $1, eval $1);
+               }
+               print "\n";
+           }
+
            print 'not ';
            last;
        }
     }
 }
-print "ok 104\n";
+print "ok 102\n";