This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Variants of several regression tests that run the actul tests inside
[perl5.git] / t / op / regexp.t
index 8a13dd2..793a474 100755 (executable)
@@ -15,6 +15,7 @@
 #      c       expect an error
 #      B       test exposes a known bug in Perl, should be skipped
 #      b       test exposes a known bug in Perl, should be skipped if noamp
+#      t       test exposes a bug with threading, TODO if qr_embed_thr
 #
 # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
 #
@@ -49,12 +50,25 @@ BEGIN {
 
     chdir 't' if -d 't';
     @INC = '../lib';
+
+    if ($qr_embed_thr) {
+       require Config;
+       if (!$Config::Config{useithreads}) {
+           print "1..0 # Skip: no ithreads\n";
+               exit 0;
+       }
+       if ($ENV{PERL_CORE_MINITEST}) {
+           print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
+               exit 0;
+       }
+       require threads;
+    }
 }
 
 use strict;
 use warnings FATAL=>"all";
 use vars qw($iters $numtests $bang $ffff $nulnul $OP);
-use vars qw($qr $skip_amp $qr_embed); # set by our callers
+use vars qw($qr $skip_amp $qr_embed $qr_embed_thr); # set by our callers
 
 
 if (!defined $file) {
@@ -73,6 +87,7 @@ $OP = $qr ? 'qr' : 'm';
 
 $| = 1;
 printf "1..%d\n# $iters iterations\n", scalar @tests;
+
 my $test;
 TEST:
 foreach (@tests) {
@@ -93,6 +108,7 @@ foreach (@tests) {
     $subject = eval qq("$subject"); die $@ if $@;
     $expect  = eval qq("$expect"); die $@ if $@;
     $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
+    my $todo = $qr_embed_thr && ($result =~ s/t//);
     my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
     $reason = 'skipping $&' if $reason eq  '' && $skip_amp;
     $result =~ s/B//i unless $skip;
@@ -120,6 +136,16 @@ EOFCODE
                 \$got = "$repl";
 EOFCODE
         }
+        elsif ($qr_embed_thr) {
+            $code= <<EOFCODE;
+               # Can't run the match in a subthread, but can do this and
+               # clone the pattern the other way.
+                my \$RE = threads->new(sub {qr$pat})->join();
+                $study;
+                \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
+                \$got = "$repl";
+EOFCODE
+        }
         else {
             $code= <<EOFCODE;
                 $study;
@@ -146,10 +172,14 @@ EOFCODE
            print "ok $test # skipped", length($reason) ? " $reason" : '', "\n";
            next TEST;
        }
+       elsif ( $todo ) {
+           print "not ok $test # todo", length($reason) ? " - $reason" : '', "\n";
+           next TEST;
+       }
        elsif ($@) {
            print "not ok $test $input => error `$err'\n$code\n$@\n"; next TEST;
        }
-       elsif ($result eq 'n') {
+       elsif ($result =~ /^n/) {
            if ($match) { print "not ok $test ($study) $input => false positive\n"; next TEST }
        }
        else {