t/re/regexp.t

   1 #!./perl
   2
   3 # The tests are in a separate file 't/re/re_tests'.
   4 # Each line in that file is a separate test.
   5 # There are five columns, separated by tabs.
   6 #
   7 # Column 1 contains the pattern, optionally enclosed in C<''>.
   8 # Modifiers can be put after the closing C<'>.
   9 #
  10 # Column 2 contains the string to be matched.
  11 #
  12 # Column 3 contains the expected result:
  13 #       y       expect a match
  14 #       n       expect no match
  15 #       c       expect an error
  16 #       T       the test is a TODO (can be combined with y/n/c)
  17 #       B       test exposes a known bug in Perl, should be skipped
  18 #       b       test exposes a known bug in Perl, should be skipped if noamp
  19 #       t       test exposes a bug with threading, TODO if qr_embed_thr
  20 #
  21 # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
  22 #
  23 # Column 4 contains a string, usually C<$&>.
  24 #
  25 # Column 5 contains the expected result of double-quote
  26 # interpolating that string after the match, or start of error message.
  27 #
  28 # Column 6, if present, contains a reason why the test is skipped.
  29 # This is printed with "skipped", for harness to pick up.
  30 #
  31 # \n in the tests are interpolated, as are variables of the form ${\w+}.
  32 #
  33 # Blanks lines are treated as PASSING tests to keep the line numbers
  34 # linked to the test number.
  35 #
  36 # If you want to add a regular expression test that can't be expressed
  37 # in this format, don't add it here: put it in re/pat.t instead.
  38 #
  39 # Note that the inputs get passed on as "m're'", so the re bypasses the lexer.
  40 # This means this file cannot be used for testing anything that the lexer
  41 # handles; in 5.12 this means just \N{NAME} and \N{U+...}.
  42 #
  43 # Note that columns 2,3 and 5 are all enclosed in double quotes and then
  44 # evalled; so something like a\"\x{100}$1 has length 3+length($1).
  45
  46 my $file;
  47 BEGIN {
  48     $iters = shift || 1;        # Poor man performance suite, 10000 is OK.
  49
  50     # Do this open before any chdir
  51     $file = shift;
  52     if (defined $file) {
  53         open TESTS, $file or die "Can't open $file";
  54     }
  55
  56     chdir 't' if -d 't';
  57     @INC = '../lib';
  58
  59     if ($qr_embed_thr) {
  60         require Config;
  61         if (!$Config::Config{useithreads}) {
  62             print "1..0 # Skip: no ithreads\n";
  63                 exit 0;
  64         }
  65         if ($ENV{PERL_CORE_MINITEST}) {
  66             print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
  67                 exit 0;
  68         }
  69         require threads;
  70     }
  71 }
  72
  73 use strict;
  74 use warnings FATAL=>"all";
  75 use vars qw($iters $numtests $bang $ffff $nulnul $OP);
  76 use vars qw($qr $skip_amp $qr_embed $qr_embed_thr); # set by our callers
  77
  78
  79 if (!defined $file) {
  80     open(TESTS,'re/re_tests') || open(TESTS,'t/re/re_tests')
  81         || open(TESTS,':re:re_tests') || die "Can't open re_tests";
  82 }
  83
  84 my @tests = <TESTS>;
  85
  86 close TESTS;
  87
  88 $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
  89 $ffff  = chr(0xff) x 2;
  90 $nulnul = "\0" x 2;
  91 $OP = $qr ? 'qr' : 'm';
  92
  93 $| = 1;
  94 printf "1..%d\n# $iters iterations\n", scalar @tests;
  95
  96 my $test;
  97 TEST:
  98 foreach (@tests) {
  99     $test++;
 100     if (!/\S/ || /^\s*#/ || /^__END__$/) {
 101         print "ok $test # (Blank line or comment)\n";
 102         if (/#/) { print $_ };
 103         next;
 104     }
 105     chomp;
 106     s/\\n/\n/g;
 107     my ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6);
 108     $reason = '' unless defined $reason;
 109     my $input = join(':',$pat,$subject,$result,$repl,$expect);
 110     # the double '' below keeps simple syntax highlighters from going crazy
 111     $pat = "'$pat'" unless $pat =~ /^[:''\/]/;
 112     $pat =~ s/(\$\{\w+\})/$1/eeg;
 113     $pat =~ s/\\n/\n/g;
 114     $subject = eval qq("$subject"); die $@ if $@;
 115     $expect  = eval qq("$expect"); die $@ if $@;
 116     $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
 117     my $todo_qr = $qr_embed_thr && ($result =~ s/t//);
 118     my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
 119     $reason = 'skipping $&' if $reason eq  '' && $skip_amp;
 120     $result =~ s/B//i unless $skip;
 121     my $todo= $result =~ s/T// ? " # TODO" : "";
 122
 123
 124     for my $study ('', 'study $subject', 'utf8::upgrade($subject)',
 125                    'utf8::upgrade($subject); study $subject') {
 126         # Need to make a copy, else the utf8::upgrade of an alreay studied
 127         # scalar confuses things.
 128         my $subject = $subject;
 129         my $c = $iters;
 130         my ($code, $match, $got);
 131         if ($repl eq 'pos') {
 132             $code= <<EOFCODE;
 133                 $study;
 134                 pos(\$subject)=0;
 135                 \$match = ( \$subject =~ m${pat}g );
 136                 \$got = pos(\$subject);
 137 EOFCODE
 138         }
 139         elsif ($qr_embed) {
 140             $code= <<EOFCODE;
 141                 my \$RE = qr$pat;
 142                 $study;
 143                 \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
 144                 \$got = "$repl";
 145 EOFCODE
 146         }
 147         elsif ($qr_embed_thr) {
 148             $code= <<EOFCODE;
 149                 # Can't run the match in a subthread, but can do this and
 150                 # clone the pattern the other way.
 151                 my \$RE = threads->new(sub {qr$pat})->join();
 152                 $study;
 153                 \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
 154                 \$got = "$repl";
 155 EOFCODE
 156         }
 157         else {
 158             $code= <<EOFCODE;
 159                 $study;
 160                 \$match = (\$subject =~ $OP$pat) while \$c--;
 161                 \$got = "$repl";
 162 EOFCODE
 163         }
 164         #$code.=qq[\n\$expect="$expect";\n];
 165         #use Devel::Peek;
 166         #die Dump($code) if $pat=~/\\h/ and $subject=~/\x{A0}/;
 167         {
 168             # Probably we should annotate specific tests with which warnings
 169             # categories they're known to trigger, and hence should be
 170             # disabled just for that test
 171             no warnings qw(uninitialized regexp);
 172             eval $code;
 173         }
 174         chomp( my $err = $@ );
 175         if ($result eq 'c') {
 176             if ($err !~ m!^\Q$expect!) { print "not ok $test$todo (compile) $input => `$err'\n"; next TEST }
 177             last;  # no need to study a syntax error
 178         }
 179         elsif ( $skip ) {
 180             print "ok $test # skipped", length($reason) ? " $reason" : '', "\n";
 181             next TEST;
 182         }
 183         elsif ( $todo_qr ) {
 184             print "not ok $test # TODO", length($reason) ? " - $reason" : '', "\n";
 185             next TEST;
 186         }
 187         elsif ($@) {
 188             print "not ok $test$todo $input => error `$err'\n$code\n$@\n"; next TEST;
 189         }
 190         elsif ($result =~ /^n/) {
 191             if ($match) { print "not ok $test$todo ($study) $input => false positive\n"; next TEST }
 192         }
 193         else {
 194             if (!$match || $got ne $expect) {
 195                 eval { require Data::Dumper };
 196                 if ($@) {
 197                     print "not ok $test$todo ($study) $input => `$got', match=$match\n$code\n";
 198                 }
 199                 else { # better diagnostics
 200                     my $s = Data::Dumper->new([$subject],['subject'])->Useqq(1)->Dump;
 201                     my $g = Data::Dumper->new([$got],['got'])->Useqq(1)->Dump;
 202                     print "not ok $test$todo ($study) $input => `$got', match=$match\n$s\n$g\n$code\n";
 203                 }
 204                 next TEST;
 205             }
 206         }
 207     }
 208     print "ok $test$todo\n";
 209 }
 210
 211 1;