From dba1316b19169da02963765f0dd334687dc9b661 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Sun, 9 Nov 2008 21:02:01 +0000
Subject: [PATCH] Add support for testing when under

#define PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0

as signalled by the environment variable REAL_POSIX_CC being true.

Otherwise test are as they used to be, or TODO'ed.

p4raw-id: //depot/perl@34785
---
 t/op/pat.t         |  7 ++++++-
 t/op/reg_posixcc.t | 51 +++++++++++++++++++++++++++++++++++++++++----------
 2 files changed, 47 insertions(+), 11 deletions(-)

diff --git a/t/op/pat.t b/t/op/pat.t
index 798a3da..bdb5128 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -2731,7 +2731,11 @@ print "# some Unicode properties\n";
     print "# SEGV in s/// and UTF-8\n";
     $s = "s#\x{100}" x 4;
     $s =~ s/[^\w]/ /g;
-    print $s eq "s \x{100}" x 4 ? "ok 861\n" : "not ok 861\n";
+    if ($ENV{REAL_POSIX_CC}) {
+        print $s eq "s  " x 4 ? "ok 861\n" : "not ok 861\n";
+    } else {
+        print $s eq "s \x{100}" x 4 ? "ok 861\n" : "not ok 861\n";
+    }
 }
 
 {
@@ -4642,6 +4646,7 @@ SKIP: {
 	grep {/[[:punct:]]/ != /\p{IsPunct}/} map {chr} 0x80..0xff;
     };
     if( $@ ){ skip( $@, 1); }
+    if( $ENV{REAL_POSIX_CC} ) { skip ('PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS set to 0',1); }
     iseq( join('', @isPunctLatin1), '', 
 	'IsPunct agrees with [:punct:] with explicit Latin1');
 } 
diff --git a/t/op/reg_posixcc.t b/t/op/reg_posixcc.t
index 7335399..f6391ef 100644
--- a/t/op/reg_posixcc.t
+++ b/t/op/reg_posixcc.t
@@ -7,7 +7,7 @@ BEGIN {
 
 use strict;
 use warnings;
-use Test::More tests => 1;
+use Test::More 'no_plan'; # otherwise it would 38401 tests, which is, uh, a lot. :-)
 my @pats=(
             "\\w",
 	    "\\W",
@@ -39,6 +39,10 @@ my @pats=(
 	    "[:^space:]",
 	    "[:blank:]",
 	    "[:^blank:]" );
+if (not $ENV{REAL_POSIX_CC}) {
+    $TODO = "Only works under PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0";
+}
+
 sub rangify {
     my $ary= shift;
     my $fmt= shift || '%d';
@@ -72,6 +76,7 @@ while (@pats) {
     
     my %err_by_type;
     my %singles;
+    my %complements;
     foreach my $b (0..255) {
         my %got;
         for my $type ('unicode','not-unicode') {
@@ -80,7 +85,11 @@ while (@pats) {
                 $str.=chr(256);
                 chop $str;
             }
-            if ($str=~/[$yes][$no]/) {
+            if ($str=~/[$yes][$no]/){
+                TODO: {
+                    unlike($str,qr/[$yes][$no]/,
+                        "chr($b)=~/[$yes][$no]/ should not match under $type");
+                }
                 push @{$err_by_type{$type}},$b;
             }
             $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0;
@@ -89,18 +98,33 @@ while (@pats) {
             $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0;
         }
         foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") {
-            if ($got{$which}{'unicode'} != $got{$which}{'not-unicode'}) {
+            if ($got{$which}{'unicode'} != $got{$which}{'not-unicode'}){
+                TODO: {
+                    is($got{$which}{'unicode'},$got{$which}{'not-unicode'},
+                        "chr($b)=~/$which/ should have the same results regardless of internal string encoding");
+                }
                 push @{$singles{$which}},$b;
             }
         }
+        foreach my $which ($yes,$no) {
+            foreach my $strtype ('unicode','not-unicode') {
+                if ($got{"[$which]"}{$strtype} == $got{"[^$which]"}{$strtype}) {
+                    TODO: {
+                        isnt($got{"[$which]"}{$strtype},$got{"[^$which]"}{$strtype},
+                            "chr($b)=~/[$which]/ should not have the same result as chr($b)=~/[^$which]/");
+                    }
+                    push @{$complements{$which}{$strtype}},$b;
+                }
+            }
+        }
     }
     
     
-    if (%err_by_type || %singles) {
+    if (%err_by_type || %singles || %complements) {
         $description||=" Error:\n";
         $description .= "/[$yes][$no]/\n";
         if (%err_by_type) {
-            foreach my $type (keys %err_by_type) {
+            foreach my $type (sort keys %err_by_type) {
                 $description .= "\tmatches $type codepoints:\t";
                 $description .= rangify($err_by_type{$type});
                 $description .= "\n";
@@ -109,19 +133,26 @@ while (@pats) {
         }
         if (%singles) {
             $description .= "Unicode/Nonunicode mismatches:\n";
-            foreach my $type (keys %singles) {
+            foreach my $type (sort keys %singles) {
                 $description .= "\t$type:\t";
                 $description .= rangify($singles{$type});
                 $description .= "\n";
             }
             $description .= "\n";
         }
-     
+        if (%complements) {
+            foreach my $class (sort keys %complements) {
+                foreach my $strtype (sort keys %{$complements{$class}}) {
+                    $description .= "\t$class has complement failures under $strtype for:\t";
+                    $description .= rangify($complements{$class}{$strtype});
+                    $description .= "\n";
+                }
+            }
+        }
     }
-    
 }
 TODO: {
-    local $TODO = "Only works under PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0";
     is( $description, "", "POSIX and perl charclasses should not depend on string type");
-};
+}
+
 __DATA__
-- 
1.8.3.1