1#!./perl 2# 3# This is a home for regular expression tests that don't fit into 4# the format supported by re/regexp.t. If you want to add a test 5# that does fit that format, add it to re/re_tests, not here. 6 7use strict; 8use warnings; 9use 5.010; 10 11 12sub run_tests; 13 14$| = 1; 15 16 17BEGIN { 18 chdir 't' if -d 't'; 19 @INC = ('../lib','.'); 20 do "re/ReTest.pl" or die $@; 21} 22 23 24plan tests => 123; # Update this when adding/deleting tests. 25 26run_tests() unless caller; 27 28# 29# Tests start here. 30# 31sub run_tests { 32 { 33 local $Message = "Call code from qr //"; 34 local $_ = 'var="foo"'; 35 $a = qr/(?{++$b})/; 36 $b = 7; 37 ok /$a$a/ && $b eq '9'; 38 39 my $c="$a"; 40 ok /$a$a/ && $b eq '11'; 41 42 undef $@; 43 eval {/$c/}; 44 ok $@ && $@ =~ /not allowed at runtime/; 45 46 use re "eval"; 47 /$a$c$a/; 48 iseq $b, '14'; 49 50 our $lex_a = 43; 51 our $lex_b = 17; 52 our $lex_c = 27; 53 my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/); 54 55 iseq $lex_res, 1; 56 iseq $lex_a, 44; 57 iseq $lex_c, 43; 58 59 no re "eval"; 60 undef $@; 61 my $match = eval { /$a$c$a/ }; 62 ok $@ && $@ =~ /Eval-group not allowed/ && !$match; 63 iseq $b, '14'; 64 65 $lex_a = 2; 66 $lex_a = 43; 67 $lex_b = 17; 68 $lex_c = 27; 69 $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/); 70 71 iseq $lex_res, 1; 72 iseq $lex_a, 44; 73 iseq $lex_c, 43; 74 75 } 76 77 { 78 our $a = bless qr /foo/ => 'Foo'; 79 ok 'goodfood' =~ $a, "Reblessed qr // matches"; 80 iseq $a, '(?-xism:foo)', "Reblessed qr // stringifies"; 81 my $x = "\x{3fe}"; 82 my $z = my $y = "\317\276"; # Byte representation of $x 83 $a = qr /$x/; 84 ok $x =~ $a, "UTF-8 interpolation in qr //"; 85 ok "a$a" =~ $x, "Stringified qr // preserves UTF-8"; 86 ok "a$x" =~ /^a$a\z/, "Interpolated qr // preserves UTF-8"; 87 ok "a$x" =~ /^a(??{$a})\z/, 88 "Postponed interpolation of qr // preserves UTF-8"; 89 { 90 local $BugId = '17776'; 91 iseq length qr /##/x, 12, "## in qr // doesn't corrupt memory"; 92 } 93 { 94 use re 'eval'; 95 ok "$x$x" =~ /^$x(??{$x})\z/, 96 "Postponed UTF-8 string in UTF-8 re matches UTF-8"; 97 ok "$y$x" =~ /^$y(??{$x})\z/, 98 "Postponed UTF-8 string in non-UTF-8 re matches UTF-8"; 99 ok "$y$x" !~ /^$y(??{$y})\z/, 100 "Postponed non-UTF-8 string in non-UTF-8 re doesn't match UTF-8"; 101 ok "$x$x" !~ /^$x(??{$y})\z/, 102 "Postponed non-UTF-8 string in UTF-8 re doesn't match UTF-8"; 103 ok "$y$y" =~ /^$y(??{$y})\z/, 104 "Postponed non-UTF-8 string in non-UTF-8 re matches non-UTF8"; 105 ok "$x$y" =~ /^$x(??{$y})\z/, 106 "Postponed non-UTF-8 string in UTF-8 re matches non-UTF8"; 107 108 $y = $z; # Reset $y after upgrade. 109 ok "$x$y" !~ /^$x(??{$x})\z/, 110 "Postponed UTF-8 string in UTF-8 re doesn't match non-UTF-8"; 111 ok "$y$y" !~ /^$y(??{$x})\z/, 112 "Postponed UTF-8 string in non-UTF-8 re doesn't match non-UTF-8"; 113 } 114 } 115 116 117 { 118 use re 'eval'; 119 local $Message = 'Test if $^N and $+ work in (?{{})'; 120 our @ctl_n = (); 121 our @plus = (); 122 our $nested_tags; 123 $nested_tags = qr{ 124 < 125 ((\w)+) 126 (?{ 127 push @ctl_n, (defined $^N ? $^N : "undef"); 128 push @plus, (defined $+ ? $+ : "undef"); 129 }) 130 > 131 (??{$nested_tags})* 132 </\s* \w+ \s*> 133 }x; 134 135 136 my $c = 0; 137 for my $test ( 138 # Test structure: 139 # [ Expected result, Regex, Expected value(s) of $^N, Expected value(s) of $+ ] 140 [ 1, qr#^$nested_tags$#, "bla blubb bla", "a b a" ], 141 [ 1, qr#^($nested_tags)$#, "bla blubb <bla><blubb></blubb></bla>", "a b a" ], 142 [ 1, qr#^(|)$nested_tags$#, "bla blubb bla", "a b a" ], 143 [ 1, qr#^(?:|)$nested_tags$#, "bla blubb bla", "a b a" ], 144 [ 1, qr#^<(bl|bla)>$nested_tags<(/\1)>$#, "blubb /bla", "b /bla" ], 145 [ 1, qr#(??{"(|)"})$nested_tags$#, "bla blubb bla", "a b a" ], 146 [ 1, qr#^(??{"(bla|)"})$nested_tags$#, "bla blubb bla", "a b a" ], 147 [ 1, qr#^(??{"(|)"})(??{$nested_tags})$#, "bla blubb undef", "a b undef" ], 148 [ 1, qr#^(??{"(?:|)"})$nested_tags$#, "bla blubb bla", "a b a" ], 149 [ 1, qr#^((??{"(?:bla|)"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ], 150 [ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ], 151 [ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ], 152 [ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ], 153 154 ) { #"#silence vim highlighting 155 $c++; 156 @ctl_n = (); 157 @plus = (); 158 my $match = (("<bla><blubb></blubb></bla>" =~ $test->[1]) ? 1 : 0); 159 push @ctl_n, (defined $^N ? $^N : "undef"); 160 push @plus, (defined $+ ? $+ : "undef"); 161 ok($test->[0] == $match, "match $c"); 162 if ($test->[0] != $match) { 163 # unset @ctl_n and @plus 164 @ctl_n = @plus = (); 165 } 166 iseq("@ctl_n", $test->[2], "ctl_n $c"); 167 iseq("@plus", $test->[3], "plus $c"); 168 } 169 } 170 171 { 172 use re 'eval'; 173 local $BugId = '56194'; 174 175 our $f; 176 local $f; 177 $f = sub { 178 defined $_[0] ? $_[0] : "undef"; 179 }; 180 181 ok("123" =~ m/^(\d)(((??{1 + $^N})))+$/); 182 183 our @ctl_n; 184 our @plus; 185 186 my $re = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})#; 187 my $re2 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})(|a(b)c|def)(??{"$^R"})#; 188 my $re3 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})(|a(b)c|def)(??{"$^R"})#; 189 our $re5; 190 local $re5 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})#; 191 my $re6 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#; 192 my $re7 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#; 193 my $re8 = qr/(\d+)/; 194 my $c = 0; 195 for my $test ( 196 # Test structure: 197 # [ 198 # String to match 199 # Regex too match 200 # Expected values of $^N 201 # Expected values of $+ 202 # Expected values of $1, $2, $3, $4 and $5 203 # ] 204 [ 205 "1233", 206 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(??{$^N})$#, 207 "1 2 3 3", 208 "1 2 3 3", 209 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", 210 ], 211 [ 212 "1233", 213 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$+})$#, 214 "1 2 3 3", 215 "1 2 3 3", 216 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", 217 ], 218 [ 219 "1233", 220 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$+})$#, 221 "1 2 3 3", 222 "1 2 3 3", 223 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", 224 ], 225 [ 226 "1233", 227 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$^N})$#, 228 "1 2 3 3", 229 "1 2 3 3", 230 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", 231 ], 232 [ 233 "1233", 234 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$^N})$#, 235 "1 2 3 3", 236 "1 2 3 3", 237 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", 238 ], 239 [ 240 "123abc3", 241 qr#^($re)(|a(b)c|def)(??{$^R})$#, 242 "1 2 3 abc", 243 "1 2 3 b", 244 "\$1 = 123, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", 245 ], 246 [ 247 "123abc3", 248 qr#^($re2)$#, 249 "1 2 3 123abc3", 250 "1 2 3 b", 251 "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", 252 ], 253 [ 254 "123abc3", 255 qr#^($re3)$#, 256 "1 2 123abc3", 257 "1 2 b", 258 "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", 259 ], 260 [ 261 "123abc3", 262 qr#^(??{$re5})(|abc|def)(??{"$^R"})$#, 263 "1 2 abc", 264 "1 2 abc", 265 "\$1 = abc, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef", 266 ], 267 [ 268 "123abc3", 269 qr#^(??{$re5})(|a(b)c|def)(??{"$^R"})$#, 270 "1 2 abc", 271 "1 2 b", 272 "\$1 = abc, \$2 = b, \$3 = undef, \$4 = undef, \$5 = undef", 273 ], 274 [ 275 "1234", 276 qr#^((\d+)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})))$#, 277 "1234 123 12 1 2 3 1234", 278 "1234 123 12 1 2 3 4", 279 "\$1 = 1234, \$2 = 1, \$3 = 2, \$4 = 3, \$5 = 4", 280 ], 281 [ 282 "1234556", 283 qr#^(\d+)($re6)($re6)($re6)$re6(($re6)$re6)$#, 284 "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 56", 285 "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 5", 286 "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 56", 287 ], 288 [ 289 "12345562", 290 qr#^((??{$re8}))($re7)($re7)($re7)$re7($re7)($re7(\2))$#, 291 "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 62", 292 "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 2", 293 "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 5", 294 ], 295 ) { 296 $c++; 297 @ctl_n = (); 298 @plus = (); 299 undef $^R; 300 my $match = $test->[0] =~ $test->[1]; 301 my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5)); 302 push @ctl_n, $f->($^N); 303 push @plus, $f->($+); 304 ok($match, "match $c"); 305 if (not $match) { 306 # unset $str, @ctl_n and @plus 307 $str = ""; 308 @ctl_n = @plus = (); 309 } 310 iseq("@ctl_n", $test->[2], "ctl_n $c"); 311 iseq("@plus", $test->[3], "plus $c"); 312 iseq($str, $test->[4], "str $c"); 313 } 314 SKIP: { 315 if ($] le '5.010') { 316 skip "test segfaults on perl < 5.10", 4; 317 } 318 319 @ctl_n = (); 320 @plus = (); 321 322 our $re4; 323 local $re4 = qr#(1)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})){2}(?{$^N})(|abc|def)(??{"$^R"})#; 324 undef $^R; 325 my $match = "123abc3" =~ m/^(??{$re4})$/; 326 my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5),'$^R = '.$f->($^R)); 327 push @ctl_n, $f->($^N); 328 push @plus, $f->($+); 329 ok($match); 330 if (not $match) { 331 # unset $str 332 @ctl_n = (); 333 @plus = (); 334 $str = ""; 335 } 336 iseq("@ctl_n", "1 2 undef"); 337 iseq("@plus", "1 2 undef"); 338 iseq($str, "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = undef"); 339 } 340 } 341 342} # End of sub run_tests 343 3441; 345