This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
reg_posixcc.t: display chr(\\xXX) should be chr(0xXX)
[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",
6e80eb23
KW
20 "\\h",
21 "\\H",
22 "\\v",
23 "\\V",
da7fcca4
YO
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:]" );
dba1316b 48
da7fcca4
YO
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
9b7c43ba
KW
76# The bug is only fixed for /u
77use feature 'unicode_strings';
78
da7fcca4
YO
79my $description = "";
80while (@pats) {
81 my ($yes,$no)= splice @pats,0,2;
82
83 my %err_by_type;
84 my %singles;
dba1316b 85 my %complements;
da7fcca4
YO
86 foreach my $b (0..255) {
87 my %got;
cb54b734 88 my $display_b = sprintf("0x%02X", $b);
803505a9 89 for my $type ('utf8','not-utf8') {
da7fcca4 90 my $str=chr($b).chr($b);
803505a9 91 if ($type eq 'utf8') {
da7fcca4
YO
92 $str.=chr(256);
93 chop $str;
94 }
dba1316b 95 if ($str=~/[$yes][$no]/){
9b7c43ba
KW
96 unlike($str,qr/[$yes][$no]/,
97 "chr($display_b) X 2 =~/[$yes][$no]/ should not match under $type");
da7fcca4
YO
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;
a8c75f4b 104
6e80eb23 105 # For \w, \s, and \d, \h, \v, also test without being in character
a8c75f4b
KW
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);
803505a9 115 utf8::upgrade $chr if $type eq 'utf8';
a8c75f4b
KW
116 ok (($chr =~ /$yes/) != ($chr =~ /$no/),
117 "$type: chr($display_b) isn't both $yes and $no");
da7fcca4
YO
118 }
119 foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") {
803505a9
KW
120 if ($got{$which}{'utf8'} != $got{$which}{'not-utf8'}){
121 is($got{$which}{'utf8'},$got{$which}{'not-utf8'},
9b7c43ba 122 "chr($display_b) X 2=~ /$which/ should have the same results regardless of internal string encoding");
da7fcca4
YO
123 push @{$singles{$which}},$b;
124 }
125 }
dba1316b 126 foreach my $which ($yes,$no) {
803505a9 127 foreach my $strtype ('utf8','not-utf8') {
dba1316b 128 if ($got{"[$which]"}{$strtype} == $got{"[^$which]"}{$strtype}) {
9b7c43ba
KW
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]/");
dba1316b
YO
131 push @{$complements{$which}{$strtype}},$b;
132 }
133 }
134 }
da7fcca4
YO
135 }
136
137
dba1316b 138 if (%err_by_type || %singles || %complements) {
da7fcca4
YO
139 $description||=" Error:\n";
140 $description .= "/[$yes][$no]/\n";
141 if (%err_by_type) {
dba1316b 142 foreach my $type (sort keys %err_by_type) {
da7fcca4
YO
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";
dba1316b 151 foreach my $type (sort keys %singles) {
da7fcca4
YO
152 $description .= "\t$type:\t";
153 $description .= rangify($singles{$type});
154 $description .= "\n";
155 }
156 $description .= "\n";
157 }
dba1316b
YO
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 }
da7fcca4 167 }
da7fcca4 168}
da7fcca4 169__DATA__