gmtime/localtime are busted around 2**48
[perl.git] / t / re / reg_posixcc.t
1 #!perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 use strict;
10 use warnings;
11 plan "no_plan";
12
13 my @pats=(
14             "\\w",
15             "\\W",
16             "\\s",
17             "\\S",
18             "\\d",
19             "\\D",
20             "[:alnum:]",
21             "[:^alnum:]",
22             "[:alpha:]",
23             "[:^alpha:]",
24             "[:ascii:]",
25             "[:^ascii:]",
26             "[:cntrl:]",
27             "[:^cntrl:]",
28             "[:graph:]",
29             "[:^graph:]",
30             "[:lower:]",
31             "[:^lower:]",
32             "[:print:]",
33             "[:^print:]",
34             "[:punct:]",
35             "[:^punct:]",
36             "[:upper:]",
37             "[:^upper:]",
38             "[:xdigit:]",
39             "[:^xdigit:]",
40             "[:space:]",
41             "[:^space:]",
42             "[:blank:]",
43             "[:^blank:]" );
44 if (1 or $ENV{PERL_TEST_LEGACY_POSIX_CC}) {
45     $::TODO = "Only works under PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0";
46 }
47
48 sub rangify {
49     my $ary= shift;
50     my $fmt= shift || '%d';
51     my $sep= shift || ' ';
52     my $rng= shift || '..';
53     
54     
55     my $first= $ary->[0];
56     my $last= $ary->[0];
57     my $ret= sprintf $fmt, $first;
58     for my $idx (1..$#$ary) {
59         if ( $ary->[$idx] != $last + 1) {
60             if ($last!=$first) {
61                 $ret.=sprintf "%s$fmt",$rng, $last;
62             }             
63             $first= $last= $ary->[$idx];
64             $ret.=sprintf "%s$fmt",$sep,$first;
65          } else {
66             $last= $ary->[$idx];
67          }
68     }
69     if ( $last != $first) {
70         $ret.=sprintf "%s$fmt",$rng, $last;
71     }
72     return $ret;
73 }
74
75 my $description = "";
76 while (@pats) {
77     my ($yes,$no)= splice @pats,0,2;
78     
79     my %err_by_type;
80     my %singles;
81     my %complements;
82     foreach my $b (0..255) {
83         my %got;
84         for my $type ('unicode','not-unicode') {
85             my $str=chr($b).chr($b);
86             if ($type eq 'unicode') {
87                 $str.=chr(256);
88                 chop $str;
89             }
90             if ($str=~/[$yes][$no]/){
91                 TODO: {
92                     unlike($str,qr/[$yes][$no]/,
93                         "chr($b)=~/[$yes][$no]/ should not match under $type");
94                 }
95                 push @{$err_by_type{$type}},$b;
96             }
97             $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0;
98             $got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0;
99             $got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0;
100             $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0;
101         }
102         foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") {
103             if ($got{$which}{'unicode'} != $got{$which}{'not-unicode'}){
104                 TODO: {
105                     is($got{$which}{'unicode'},$got{$which}{'not-unicode'},
106                         "chr($b)=~/$which/ should have the same results regardless of internal string encoding");
107                 }
108                 push @{$singles{$which}},$b;
109             }
110         }
111         foreach my $which ($yes,$no) {
112             foreach my $strtype ('unicode','not-unicode') {
113                 if ($got{"[$which]"}{$strtype} == $got{"[^$which]"}{$strtype}) {
114                     TODO: {
115                         isnt($got{"[$which]"}{$strtype},$got{"[^$which]"}{$strtype},
116                             "chr($b)=~/[$which]/ should not have the same result as chr($b)=~/[^$which]/");
117                     }
118                     push @{$complements{$which}{$strtype}},$b;
119                 }
120             }
121         }
122     }
123     
124     
125     if (%err_by_type || %singles || %complements) {
126         $description||=" Error:\n";
127         $description .= "/[$yes][$no]/\n";
128         if (%err_by_type) {
129             foreach my $type (sort keys %err_by_type) {
130                 $description .= "\tmatches $type codepoints:\t";
131                 $description .= rangify($err_by_type{$type});
132                 $description .= "\n";
133             }
134             $description .= "\n";
135         }
136         if (%singles) {
137             $description .= "Unicode/Nonunicode mismatches:\n";
138             foreach my $type (sort keys %singles) {
139                 $description .= "\t$type:\t";
140                 $description .= rangify($singles{$type});
141                 $description .= "\n";
142             }
143             $description .= "\n";
144         }
145         if (%complements) {
146             foreach my $class (sort keys %complements) {
147                 foreach my $strtype (sort keys %{$complements{$class}}) {
148                     $description .= "\t$class has complement failures under $strtype for:\t";
149                     $description .= rangify($complements{$class}{$strtype});
150                     $description .= "\n";
151                 }
152             }
153         }
154     }
155 }
156 TODO: {
157     is( $description, "", "POSIX and perl charclasses should not depend on string type");
158 }
159
160 __DATA__