1#!perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    require './test.pl';
6    set_up_inc('../lib');
7}
8
9use strict;
10use warnings;
11plan "no_plan";
12
13my @pats=(
14            "\\w",
15	    "\\W",
16	    "\\s",
17	    "\\S",
18	    "\\d",
19	    "\\D",
20            "\\h",
21	    "\\H",
22            "\\v",
23	    "\\V",
24	    "[:alnum:]",
25	    "[:^alnum:]",
26	    "[:alpha:]",
27	    "[:^alpha:]",
28	    "[:ascii:]",
29	    "[:^ascii:]",
30	    "[:cntrl:]",
31	    "[:^cntrl:]",
32	    "[:graph:]",
33	    "[:^graph:]",
34	    "[:lower:]",
35	    "[:^lower:]",
36	    "[:print:]",
37	    "[:^print:]",
38	    "[:punct:]",
39	    "[:^punct:]",
40	    "[:upper:]",
41	    "[:^upper:]",
42	    "[:xdigit:]",
43	    "[:^xdigit:]",
44	    "[:space:]",
45	    "[:^space:]",
46	    "[:blank:]",
47	    "[:^blank:]" );
48
49sub rangify {
50    my $ary= shift;
51    my $fmt= shift || '%d';
52    my $sep= shift || ' ';
53    my $rng= shift || '..';
54    
55    
56    my $first= $ary->[0];
57    my $last= $ary->[0];
58    my $ret= sprintf $fmt, $first;
59    for my $idx (1..$#$ary) {
60        if ( $ary->[$idx] != $last + 1) {
61            if ($last!=$first) {
62                $ret.=sprintf "%s$fmt",$rng, $last;
63            }             
64            $first= $last= $ary->[$idx];
65            $ret.=sprintf "%s$fmt",$sep,$first;
66         } else {
67            $last= $ary->[$idx];
68         }
69    }
70    if ( $last != $first) {
71        $ret.=sprintf "%s$fmt",$rng, $last;
72    }
73    return $ret;
74}
75
76# The bug is only fixed for /u
77use feature 'unicode_strings';
78
79my $description = "";
80while (@pats) {
81    my ($yes,$no)= splice @pats,0,2;
82    
83    my %err_by_type;
84    my %singles;
85    my %complements;
86    foreach my $b (0..255) {
87        my %got;
88        my $display_b = sprintf("0x%02X", $b);
89        for my $type ('utf8','not-utf8') {
90            my $str=chr($b).chr($b);
91            if ($type eq 'utf8') {
92                $str.=chr(256);
93                chop $str;
94            }
95            if ($str=~/[$yes][$no]/){
96                unlike($str,qr/[$yes][$no]/,
97                    "chr($display_b) X 2 =~/[$yes][$no]/ should not match under $type");
98                push @{$err_by_type{$type}},$b;
99            }
100            $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0;
101            $got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0;
102            $got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0;
103            $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0;
104
105            # For \w, \s, and \d, \h, \v, also test without being in character
106            # classes.
107            next if $yes =~ /\[/;
108
109            # The rest of this .t was written when there were many test
110            # failures, so it goes to some lengths to summarize things.  Now
111            # those are fixed, so these missing tests just do standard
112            # procedures
113
114            my $chr = chr($b);
115            utf8::upgrade $chr if $type eq 'utf8';
116            ok (($chr =~ /$yes/) != ($chr =~ /$no/),
117                "$type: chr($display_b) isn't both $yes and $no");
118        }
119        foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") {
120            if ($got{$which}{'utf8'} != $got{$which}{'not-utf8'}){
121                is($got{$which}{'utf8'},$got{$which}{'not-utf8'},
122                    "chr($display_b) X 2=~ /$which/ should have the same results regardless of internal string encoding");
123                push @{$singles{$which}},$b;
124            }
125        }
126        foreach my $which ($yes,$no) {
127            foreach my $strtype ('utf8','not-utf8') {
128                if ($got{"[$which]"}{$strtype} == $got{"[^$which]"}{$strtype}) {
129                    isnt($got{"[$which]"}{$strtype},$got{"[^$which]"}{$strtype},
130                        "chr($display_b) X 2 =~ /[$which]/ should not have the same result as chr($display_b)=~/[^$which]/");
131                    push @{$complements{$which}{$strtype}},$b;
132                }
133            }
134        }
135    }
136    
137    
138    if (%err_by_type || %singles || %complements) {
139        $description||=" Error:\n";
140        $description .= "/[$yes][$no]/\n";
141        if (%err_by_type) {
142            foreach my $type (sort keys %err_by_type) {
143                $description .= "\tmatches $type codepoints:\t";
144                $description .= rangify($err_by_type{$type});
145                $description .= "\n";
146            }
147            $description .= "\n";
148        }
149        if (%singles) {
150            $description .= "Unicode/Nonunicode mismatches:\n";
151            foreach my $type (sort keys %singles) {
152                $description .= "\t$type:\t";
153                $description .= rangify($singles{$type});
154                $description .= "\n";
155            }
156            $description .= "\n";
157        }
158        if (%complements) {
159            foreach my $class (sort keys %complements) {
160                foreach my $strtype (sort keys %{$complements{$class}}) {
161                    $description .= "\t$class has complement failures under $strtype for:\t";
162                    $description .= rangify($complements{$class}{$strtype});
163                    $description .= "\n";
164                }
165            }
166        }
167    }
168}
169__DATA__
170