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 columns 2,3 and 5 are all enclosed in double quotes and then
  40 # evalled; so something like a\"\x{100}$1 has length 3+length($1).
  41
  42 my $file;
  43 BEGIN {
  44     $iters = shift || 1;        # Poor man performance suite, 10000 is OK.
  45
  46     # Do this open before any chdir
  47     $file = shift;
  48     if (defined $file) {
  49         open TESTS, $file or die "Can't open $file";
  50     }
  51
  52     chdir 't' if -d 't';
  53     @INC = '../lib';
  54
  55     if ($qr_embed_thr) {
  56         require Config;
  57         if (!$Config::Config{useithreads}) {
  58             print "1..0 # Skip: no ithreads\n";
  59                 exit 0;
  60         }
  61         if ($ENV{PERL_CORE_MINITEST}) {
  62             print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
  63                 exit 0;
  64         }
  65         require threads;
  66     }
  67 }
  68
  69 use strict;
  70 use warnings FATAL=>"all";
  71 use vars qw($iters $numtests $bang $ffff $nulnul $OP);
  72 use vars qw($qr $skip_amp $qr_embed $qr_embed_thr); # set by our callers
  73
  74
  75 if (!defined $file) {
  76     open(TESTS,'re/re_tests') || open(TESTS,'t/re/re_tests')
  77         || open(TESTS,':re:re_tests') || die "Can't open re_tests";
  78 }
  79
  80 my @tests = <TESTS>;
  81
  82 close TESTS;
  83
  84 $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
  85 $ffff  = chr(0xff) x 2;
  86 $nulnul = "\0" x 2;
  87 $OP = $qr ? 'qr' : 'm';
  88
  89 $| = 1;
  90 printf "1..%d\n# $iters iterations\n", scalar @tests;
  91
  92 my $test;
  93 TEST:
  94 foreach (@tests) {
  95     $test++;
  96     if (!/\S/ || /^\s*#/ || /^__END__$/) {
  97         print "ok $test # (Blank line or comment)\n";
  98         if (/#/) { print $_ };
  99         next;
 100     }
 101     chomp;
 102     s/\\n/\n/g;
 103     my ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6);
 104     $reason = '' unless defined $reason;
 105     my $input = join(':',$pat,$subject,$result,$repl,$expect);
 106     # the double '' below keeps simple syntax highlighters from going crazy
 107     $pat = "'$pat'" unless $pat =~ /^[:''\/]/;
 108     $pat =~ s/(\$\{\w+\})/$1/eeg;
 109     $pat =~ s/\\n/\n/g;
 110     $subject = eval qq("$subject"); die $@ if $@;
 111     $expect  = eval qq("$expect"); die $@ if $@;
 112     $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
 113     my $todo_qr = $qr_embed_thr && ($result =~ s/t//);
 114     my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
 115     $reason = 'skipping $&' if $reason eq  '' && $skip_amp;
 116     $result =~ s/B//i unless $skip;
 117     my $todo= $result =~ s/T// ? " # TODO" : "";
 118
 119
 120     for my $study ('', 'study $subject', 'utf8::upgrade($subject)',
 121                    'utf8::upgrade($subject); study $subject') {
 122         # Need to make a copy, else the utf8::upgrade of an alreay studied
 123         # scalar confuses things.
 124         my $subject = $subject;
 125         my $c = $iters;
 126         my ($code, $match, $got);
 127         if ($repl eq 'pos') {
 128             $code= <<EOFCODE;
 129                 $study;
 130                 pos(\$subject)=0;
 131                 \$match = ( \$subject =~ m${pat}g );
 132                 \$got = pos(\$subject);
 133 EOFCODE
 134         }
 135         elsif ($qr_embed) {
 136             $code= <<EOFCODE;
 137                 my \$RE = qr$pat;
 138                 $study;
 139                 \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
 140                 \$got = "$repl";
 141 EOFCODE
 142         }
 143         elsif ($qr_embed_thr) {
 144             $code= <<EOFCODE;
 145                 # Can't run the match in a subthread, but can do this and
 146                 # clone the pattern the other way.
 147                 my \$RE = threads->new(sub {qr$pat})->join();
 148                 $study;
 149                 \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
 150                 \$got = "$repl";
 151 EOFCODE
 152         }
 153         else {
 154             $code= <<EOFCODE;
 155                 $study;
 156                 \$match = (\$subject =~ $OP$pat) while \$c--;
 157                 \$got = "$repl";
 158 EOFCODE
 159         }
 160         #$code.=qq[\n\$expect="$expect";\n];
 161         #use Devel::Peek;
 162         #die Dump($code) if $pat=~/\\h/ and $subject=~/\x{A0}/;
 163         {
 164             # Probably we should annotate specific tests with which warnings
 165             # categories they're known to trigger, and hence should be
 166             # disabled just for that test
 167             no warnings qw(uninitialized regexp);
 168             eval $code;
 169         }
 170         chomp( my $err = $@ );
 171         if ($result eq 'c') {
 172             if ($err !~ m!^\Q$expect!) { print "not ok $test$todo (compile) $input => `$err'\n"; next TEST }
 173             last;  # no need to study a syntax error
 174         }
 175         elsif ( $skip ) {
 176             print "ok $test # skipped", length($reason) ? " $reason" : '', "\n";
 177             next TEST;
 178         }
 179         elsif ( $todo_qr ) {
 180             print "not ok $test # TODO", length($reason) ? " - $reason" : '', "\n";
 181             next TEST;
 182         }
 183         elsif ($@) {
 184             print "not ok $test$todo $input => error `$err'\n$code\n$@\n"; next TEST;
 185         }
 186         elsif ($result =~ /^n/) {
 187             if ($match) { print "not ok $test$todo ($study) $input => false positive\n"; next TEST }
 188         }
 189         else {
 190             if (!$match || $got ne $expect) {
 191                 eval { require Data::Dumper };
 192                 if ($@) {
 193                     print "not ok $test$todo ($study) $input => `$got', match=$match\n$code\n";
 194                 }
 195                 else { # better diagnostics
 196                     my $s = Data::Dumper->new([$subject],['subject'])->Useqq(1)->Dump;
 197                     my $g = Data::Dumper->new([$got],['got'])->Useqq(1)->Dump;
 198                     print "not ok $test$todo ($study) $input => `$got', match=$match\n$s\n$g\n$code\n";
 199                 }
 200                 next TEST;
 201             }
 202         }
 203     }
 204     print "ok $test$todo\n";
 205 }
 206
 207 1;