This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
revert to 5.8.x semantics for \s \w and \d
[perl5.git] / t / re / reg_posixcc.t
CommitLineData
da7fcca4
YO
1#!perl
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
0214bff6 6 require './test.pl';
da7fcca4
YO
7}
8
9use strict;
10use warnings;
0214bff6
RGS
11plan "no_plan";
12
da7fcca4
YO
13my @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:]" );
2e84be61 44if (1 or $ENV{PERL_TEST_LEGACY_POSIX_CC}) {
0214bff6 45 $::TODO = "Only works under PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0";
dba1316b
YO
46}
47
da7fcca4
YO
48sub 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
75my $description = "";
76while (@pats) {
77 my ($yes,$no)= splice @pats,0,2;
78
79 my %err_by_type;
80 my %singles;
dba1316b 81 my %complements;
da7fcca4
YO
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 }
dba1316b
YO
90 if ($str=~/[$yes][$no]/){
91 TODO: {
92 unlike($str,qr/[$yes][$no]/,
93 "chr($b)=~/[$yes][$no]/ should not match under $type");
94 }
da7fcca4
YO
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]") {
dba1316b
YO
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 }
da7fcca4
YO
108 push @{$singles{$which}},$b;
109 }
110 }
dba1316b
YO
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 }
da7fcca4
YO
122 }
123
124
dba1316b 125 if (%err_by_type || %singles || %complements) {
da7fcca4
YO
126 $description||=" Error:\n";
127 $description .= "/[$yes][$no]/\n";
128 if (%err_by_type) {
dba1316b 129 foreach my $type (sort keys %err_by_type) {
da7fcca4
YO
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";
dba1316b 138 foreach my $type (sort keys %singles) {
da7fcca4
YO
139 $description .= "\t$type:\t";
140 $description .= rangify($singles{$type});
141 $description .= "\n";
142 }
143 $description .= "\n";
144 }
dba1316b
YO
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 }
da7fcca4 154 }
da7fcca4
YO
155}
156TODO: {
da7fcca4 157 is( $description, "", "POSIX and perl charclasses should not depend on string type");
dba1316b
YO
158}
159
da7fcca4 160__DATA__