This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
bisect.pl can now optionally timeout the user's test case.
[perl5.git] / Porting / bisect-runner.pl
index 95da68e..83d0a87 100755 (executable)
@@ -14,6 +14,10 @@ my %options =
      clean => 1, # mostly for debugging this
     );
 
+# We accept #!./miniperl and #!./perl
+# We don't accept #!miniperl and #!perl as their intent is ambiguous
+my $run_with_our_perl = qr{\A#!(\./(?:mini)?perl)\b};
+
 my $linux64 = `uname -sm` eq "Linux x86_64\n" ? '64' : '';
 
 my @paths;
@@ -32,18 +36,22 @@ if ($^O eq 'linux') {
             push @paths, $_;
         }
     }
+    push @paths, map {$_ . $linux64} qw(/usr/local/lib /lib /usr/lib)
+        if $linux64;
 }
 
-push @paths, map {$_ . $linux64} qw(/usr/local/lib /lib /usr/lib);
-
 my %defines =
     (
      usedevel => '',
      optimize => '-g',
      ld => 'cc',
-     ($linux64 ? (libpth => \@paths) : ()),
+     (@paths ? (libpth => \@paths) : ()),
     );
 
+# Needed for the 'ignore_versioned_solibs' emulation below.
+push @paths, qw(/usr/local/lib /lib /usr/lib)
+        unless $linux64;
+
 unless(GetOptions(\%options,
                   'target=s', 'make=s', 'jobs|j=i', 'expect-pass=i',
                   'expect-fail' => sub { $options{'expect-pass'} = 0; },
@@ -52,9 +60,11 @@ unless(GetOptions(\%options,
                       $options{match} = $_[1];
                       $options{'expect-pass'} = 0;
                   },
-                  'force-manifest', 'force-regen', 'test-build', 'validate',
-                  'all-fixups', 'early-fixup=s@', 'late-fixup=s@',
-                  'check-args', 'check-shebang!', 'usage|help|?', 'A=s@',
+                  'force-manifest', 'force-regen', 'setpgrp!', 'timeout=i',
+                  'test-build', 'validate',
+                  'all-fixups', 'early-fixup=s@', 'late-fixup=s@', 'valgrind',
+                  'check-args', 'check-shebang!', 'usage|help|?', 'gold=s',
+                  'A=s@',
                   'D=s@' => sub {
                       my (undef, $val) = @_;
                       if ($val =~ /\A([^=]+)=(.*)/s) {
@@ -109,6 +119,8 @@ bisect.pl - use git bisect to pinpoint changes
          --expect-fail -e 'my $a := 2;'
     # What was the last revision to build with these options?
     .../Porting/bisect.pl --test-build -Dd_dosuid
+    # When did this test program start generating errors from valgrind?
+    .../Porting/bisect.pl --valgrind ../test_prog.pl
 
 =head1 DESCRIPTION
 
@@ -151,7 +163,10 @@ commit which caused the failure.
 
 Because the test case is the complete argument to C<system>, it is easy to
 run something other than the F<perl> built, if necessary. If you need to run
-the perl built, you'll probably need to invoke it as C<./perl -Ilib ...>
+the perl built, you'll probably need to invoke it as C<./perl -Ilib ...>.
+As a special case, if the first argument of the test case is a readable file
+(whether executable or not), matching C<qr{\A#!./(?:mini)?perl\b}> then it
+will have C<./perl> <-Ilib> (or C<./miniperl>) prepended to it.
 
 You need a clean checkout to run a bisect, and you can't use the checkout
 which contains F<Porting/bisect.pl> (because C<git bisect>) will check out
@@ -180,10 +195,13 @@ If your F<db.h> is old enough you can override this with C<-Unoextensions>.
 
 Earliest revision to test, as a I<commit-ish> (a tag, commit or anything
 else C<git> understands as a revision). If not specified, F<bisect.pl> will
-search stable perl releases until it finds one where the test case passes.
-The default is to search from 5.002 to 5.14.0. If F<bisect.pl> detects that
-the checkout is on a case insensitive file system, it will search from
-5.005 to 5.14.0
+search stable .0 perl releases until it finds one where the test case passes
+(5.16.0 at the time of writing). The default is to search from 5.002 to the
+most recent tagged stable release.  If F<bisect.pl> detects that the
+checkout is on a case insensitive file system, it will search from 5.005 to
+the most recent tagged stable release. Only .0 stable releases are used
+because these are the only stable releases that are parents of blead, and
+hence suitable for a bisect run.
 
 =item *
 
@@ -398,6 +416,24 @@ C<--no-match ...> is implemented as C<--expect-fail --match ...>
 
 =item *
 
+--valgrind
+
+Run the test program under C<valgrind>. If you need to test for memory
+errors when parsing invalid programs, the default parser fail exit code of
+255 will always override C<valgrind>, so try putting the test case invalid
+code inside a I<string> C<eval>, so that the perl interpreter will exit with 0.
+(Be sure to check the output of $@, to avoid missing mistakes such as
+unintended C<eval> failures due to incorrect C<@INC>)
+
+Specifically, this option prepends C<valgrind> C<--error-exitcode=124> to
+the command line that runs the testcase, to cause valgrind to exit non-zero
+if it detects errors, with the assumption that the test program itself
+always exits with zero. If you require more flexibility than this, either
+specify your C<valgrind> invocation explicitly as part of the test case, or
+use a wrapper script to control the command line or massage the exit codes.
+
+=item *
+
 --test-build
 
 Test that the build completes, without running any test case.
@@ -452,6 +488,21 @@ C<--expect-pass=0> is equivalent to C<--expect-fail>. I<1> is the default.
 
 =item *
 
+--timeout I<seconds>
+
+Run the testcase with the given timeout. If this is exceeded, kill it (and
+by default all its children), and treat it as a failure.
+
+=item *
+
+--setpgrp
+
+Run the testcase in its own process group. Specifically, call C<setpgrp 0, 0>
+just before C<exec>-ing the user testcase. The default is not to set the
+process group, unless a timeout is used.
+
+=item *
+
 --all-fixups
 
 F<bisect-runner.pl> will minimally patch various files on a platform and
@@ -535,12 +586,12 @@ Passing this to F<bisect.pl> will likely cause the bisect to fail badly.
 
 --validate
 
-Test that all stable revisions can be built. By default, attempts to build
-I<blead>, I<v5.14.0> .. I<perl-5.002> (or I<perl5.005> on a case insensitive
-file system). Stops at the first failure, without
-cleaning the checkout. Use I<--start> to specify the earliest revision to
-test, I<--end> to specify the most recent. Useful for validating a new
-OS/CPU/compiler combination. For example
+Test that all stable (.0) revisions can be built. By default, attempts to
+build I<blead>, then tagged stable releases in reverse order down to
+I<perl-5.002> (or I<perl5.005> on a case insensitive file system). Stops at
+the first failure, without cleaning the checkout. Use I<--start> to specify
+the earliest revision to test, I<--end> to specify the most recent. Useful
+for validating a new OS/CPU/compiler combination. For example
 
     ../perl/Porting/bisect.pl --validate -le 'print "Hello from $]"'
 
@@ -559,16 +610,24 @@ Validate the options and arguments, and exit silently if they are valid.
 
 Validate that the test case isn't an executable file with a
 C<#!/usr/bin/perl> line (or similar). As F<bisect-runner.pl> does B<not>
-prepend C<./perl> to the test case, a I<#!> line specifying an external
-F<perl> binary will cause the test case to always run with I<that> F<perl>,
-not the F<perl> built by the bisect runner. Likely this is not what you
-wanted. If your test case is actually a wrapper script to run other
+automatically prepend C<./perl> to the test case, a I<#!> line specifying an
+external F<perl> binary will cause the test case to always run with I<that>
+F<perl>, not the F<perl> built by the bisect runner. Likely this is not what
+you wanted. If your test case is actually a wrapper script to run other
 commands, you should run it with an explicit interpreter, to be clear. For
 example, instead of C<../perl/Porting/bisect.pl ~/test/testcase.pl> you'd
 run C<../perl/Porting/bisect.pl /usr/bin/perl ~/test/testcase.pl>
 
 =item *
 
+--gold
+
+Revision to use when checking out known-good recent versions of files,
+such as F<makedepend.SH>. F<bisect-runner.pl> defaults this to I<blead>,
+but F<bisect.pl> will default it to the most recent stable release.
+
+=item *
+
 --usage
 
 =item *
@@ -668,6 +727,71 @@ sub system_or_die {
     system($command) and croak_255("'$command' failed, \$!=$!, \$?=$?");
 }
 
+sub run_with_options {
+    my $options = shift;
+    my $name = $options->{name};
+    $name = "@_" unless defined $name;
+
+    my $setgrp = $options->{setpgrp};
+    if ($options->{timeout}) {
+        # Unless you explicitly disabled it on the commandline, set it:
+        $setgrp = 1 unless defined $setgrp;
+    }
+    my $pid = fork;
+    die_255("Can't fork: $!") unless defined $pid;
+    if (!$pid) {
+        if (exists $options->{stdin}) {
+            open STDIN, '<', $options->{stdin}
+              or die "Can't open STDIN from $options->{stdin}: $!";
+        }
+        if ($setgrp) {
+            setpgrp 0, 0
+                or die "Can't setpgrp 0, 0: $!";
+        }
+        { exec @_ };
+        die_255("Failed to start $name: $!");
+    }
+    my $start;
+    if ($options->{timeout}) {
+        require Errno;
+        require POSIX;
+        die_255("No POSIX::WNOHANG")
+            unless &POSIX::WNOHANG;
+        $start = time;
+        $SIG{ALRM} = sub {
+            my $victim = $setgrp ? -$pid : $pid;
+            my $delay = 1;
+            kill 'TERM', $victim;
+            waitpid(-1, &POSIX::WNOHANG);
+            while (kill 0, $victim) {
+                sleep $delay;
+                waitpid(-1, &POSIX::WNOHANG);
+                $delay *= 2;
+                if ($delay > 8) {
+                    if (kill 'KILL', $victim) {
+                        print STDERR "$0: Had to kill 'KILL', $victim\n"
+                    } elsif (! $!{ESRCH}) {
+                        print STDERR "$0: kill 'KILL', $victim failed: $!\n";
+                    }
+                    last;
+                }
+            }
+            report_and_exit(0, 'No timeout', 'Timeout', "when running $name");
+        };
+        alarm $options->{timeout};
+    }
+    waitpid $pid, 0
+      or die_255("wait for $name, pid $pid failed: $!");
+    alarm 0;
+    if ($options->{timeout}) {
+        my $elapsed = time - $start;
+        if ($elapsed / $options->{timeout} > 0.8) {
+            print STDERR "$0: Beware, took $elapsed seconds of $options->{timeout} permitted to run $name\n";
+        }
+    }
+    return $?;
+}
+
 sub extract_from_file {
     my ($file, $rx, $default) = @_;
     my $fh = open_or_die($file);
@@ -870,7 +994,7 @@ sub revert_commit {
 
 sub checkout_file {
     my ($file, $commit) = @_;
-    $commit ||= 'blead';
+    $commit ||= $options{gold} || 'blead';
     system "git show $commit:$file > $file </dev/null"
         and die_255("Could not extract $file at revision $commit");
 }
@@ -878,14 +1002,15 @@ sub checkout_file {
 sub check_shebang {
     my $file = shift;
     return unless -e $file;
+    my $fh = open_or_die($file);
+    my $line = <$fh>;
+    return if $line =~ $run_with_our_perl;
     if (!-x $file) {
         die_255("$file is not executable.
 system($file, ...) is always going to fail.
 
 Bailing out");
     }
-    my $fh = open_or_die($file);
-    my $line = <$fh>;
     return unless $line =~ m{\A#!(/\S+/perl\S*)\s};
     die_255("$file will always be run by $1
 It won't be tested by the ./perl we build.
@@ -924,20 +1049,27 @@ sub skip {
 }
 
 sub report_and_exit {
-    my ($ret, $pass, $fail, $desc) = @_;
+    my ($good, $pass, $fail, $desc) = @_;
 
     clean();
 
-    my $got = ($options{'expect-pass'} ? !$ret : $ret) ? 'good' : 'bad';
-    if ($ret) {
-        print "$got - $fail $desc\n";
-    } else {
+    my $got = ($options{'expect-pass'} ? $good : !$good) ? 'good' : 'bad';
+    if ($good) {
         print "$got - $pass $desc\n";
+    } else {
+        print "$got - $fail $desc\n";
     }
 
     exit($got eq 'bad');
 }
 
+sub run_report_and_exit {
+    my $ret = run_with_options({setprgp => $options{setpgrp},
+                                timeout => $options{timeout},
+                               }, @_);
+    report_and_exit(!$ret, 'zero exit from', 'non-zero exit from', "@_");
+}
+
 sub match_and_exit {
     my ($target, @globs) = @_;
     my $matches = 0;
@@ -974,7 +1106,7 @@ sub match_and_exit {
         }
         close_or_die($fh);
     }
-    report_and_exit(!$matches,
+    report_and_exit($matches,
                     $matches == 1 ? '1 match for' : "$matches matches for",
                     'no matches for', $match);
 }
@@ -1005,6 +1137,21 @@ my $major
                        qr/^#define\s+(?:PERL_VERSION|PATCHLEVEL)\s+(\d+)\s/,
                        0);
 
+my $unfixable_db_file;
+
+if ($major < 10
+    && !extract_from_file('ext/DB_File/DB_File.xs',
+                          qr!^#else /\* Berkeley DB Version > 2 \*/$!)) {
+    # This DB_File.xs is really too old to patch up.
+    # Skip DB_File, unless we're invoked with an explicit -Unoextensions
+    if (!exists $defines{noextensions}) {
+        $defines{noextensions} = 'DB_File';
+    } elsif (defined $defines{noextensions}) {
+        $defines{noextensions} .= ' DB_File';
+    }
+    ++$unfixable_db_file;
+}
+
 patch_Configure();
 patch_hints();
 if ($options{'all-fixups'}) {
@@ -1075,21 +1222,13 @@ foreach my $key (sort keys %defines) {
 }
 push @ARGS, map {"-A$_"} @{$options{A}};
 
-# </dev/null because it seems that some earlier versions of Configure can
-# call commands in a way that now has them reading from stdin (and hanging)
-my $pid = fork;
-die_255("Can't fork: $!") unless defined $pid;
-if (!$pid) {
-    open STDIN, '<', '/dev/null';
-    # If a file in MANIFEST is missing, Configure asks if you want to
-    # continue (the default being 'n'). With stdin closed or /dev/null,
-    # it exits immediately and the check for config.sh below will skip.
-    no warnings; # Don't tell me "statement unlikely to be reached". I know.
-    exec './Configure', @ARGS;
-    die_255("Failed to start Configure: $!");
-}
-waitpid $pid, 0
-    or die_255("wait for Configure, pid $pid failed: $!");
+# If a file in MANIFEST is missing, Configure asks if you want to
+# continue (the default being 'n'). With stdin closed or /dev/null,
+# it exits immediately and the check for config.sh below will skip.
+# Without redirecting stdin, the commands called will attempt to read from
+# stdin (and thus effectively hang)
+run_with_options({stdin => '/dev/null', name => 'Configure'},
+                 './Configure', @ARGS);
 
 patch_SH() unless $options{'all-fixups'};
 apply_fixups($options{'late-fixup'});
@@ -1103,13 +1242,12 @@ if (-f 'config.sh') {
 
 if ($target =~ /config\.s?h/) {
     match_and_exit($target, @ARGV) if $match && -f $target;
-    report_and_exit(!-f $target, 'could build', 'could not build', $target)
+    report_and_exit(-f $target, 'could build', 'could not build', $target)
         if $options{'test-build'};
 
     skip("could not build $target") unless -f $target;
 
-    my $ret = system @ARGV;
-    report_and_exit($ret, 'zero exit from', 'non-zero exit from', "@ARGV");
+    run_report_and_exit(@ARGV);
 } elsif (!-f 'config.sh') {
     # Skip if something went wrong with Configure
 
@@ -1180,7 +1318,7 @@ if ($expected_file_found && $expected_file eq 't/perl') {
 }
 
 if ($options{'test-build'}) {
-    report_and_exit(!$expected_file_found, 'could build', 'could not build',
+    report_and_exit($expected_file_found, 'could build', 'could not build',
                     $real_target);
 } elsif (!$expected_file_found) {
     skip("could not build $real_target");
@@ -1197,6 +1335,26 @@ if (defined $options{'one-liner'}) {
     unshift @ARGV, "./$exe", '-Ilib';
 }
 
+if (-f $ARGV[0]) {
+    my $fh = open_or_die($ARGV[0]);
+    my $line = <$fh>;
+    unshift @ARGV, $1, '-Ilib'
+        if $line =~ $run_with_our_perl;
+}
+
+if ($options{valgrind}) {
+    # Turns out to be too confusing to use an optional argument with the path
+    # of the valgrind binary, as if --valgrind takes an optional argument,
+    # then specifying it as the last option eats the first part of the testcase.
+    # ie this: .../bisect.pl --valgrind testcase
+    # is treated as --valgrind=testcase and as there is no test case given,
+    # it's an invalid commandline, bailing out with the usage message.
+
+    # Currently, the test script can't signal a skip with 125, so anything
+    # non-zero would do. But to keep that option open in future, use 124
+    unshift @ARGV, 'valgrind', '--error-exitcode=124';
+}
+
 # This is what we came here to run:
 
 if (exists $Config{ldlibpthname}) {
@@ -1210,9 +1368,7 @@ if (exists $Config{ldlibpthname}) {
     }
 }
 
-my $ret = system @ARGV;
-
-report_and_exit($ret, 'zero exit from', 'non-zero exit from', "@ARGV");
+run_report_and_exit(@ARGV);
 
 ############################################################################
 #
@@ -1992,6 +2148,11 @@ EOT
                 }
             }
         }
+    } elsif ($^O eq 'solaris') {
+        if (($major == 13 || $major == 14)
+            && extract_from_file('hints/solaris_2.sh', qr/getconfldllflags/)) {
+            apply_commit('c80bde4388070c45');
+        }
     }
 }
 
@@ -2582,7 +2743,22 @@ EOPATCH
     if ($major == 4 && $^O eq 'linux') {
         # Whilst this is fixed properly in f0784f6a4c3e45e1 which provides the
         # Configure probe, it's easier to back out the problematic changes made
-        # in these previous commits:
+        # in these previous commits.
+
+        # In maint-5.004, the simplest addition is to "correct" the file to
+        # use the same pre-processor macros as blead had used. Whilst commit
+        # 9b599b2a63d2324d (reverted below) is described as
+        # [win32] merge change#887 from maintbranch
+        # it uses __sun__ and __svr4__ instead of the __sun and __SVR4 of the
+        # maint branch commit 6cdf74fe31f049dc
+
+        edit_file('doio.c', sub {
+                      my $code = shift;
+                      $code =~ s{defined\(__sun\) && defined\(__SVR4\)}
+                                {defined(__sun__) && defined(__svr4__)}g;
+                      return $code;
+                  });
+
         if (extract_from_file('doio.c',
                               qr!^/\* XXX REALLY need metaconfig test \*/$!)) {
             revert_commit('4682965a1447ea44', 'doio.c');
@@ -2899,6 +3075,16 @@ index 2a6cbcd..eab2de1 100644
 EOPATCH
     }
 
+    if ($major == 7 && $^O eq 'aix' &&
+        extract_from_file('ext/List/Util/Util.xs', qr/PUSHBLOCK/)
+        && !extract_from_file('makedef.pl', qr/^Perl_cxinc/)) {
+        # Need this to get List::Utils 1.03 and later to compile.
+        # 1.03 also expects to call Perl_pp_rand. Commit d3632a54487acc5f
+        # fixes this (for the unthreaded case), but it's not until 1.05,
+        # two days later, that this is fixed properly.
+        apply_commit('cbb96eed3f175499');
+    }
+
     if (($major >= 7 || $major <= 9) && $^O eq 'openbsd'
         && `uname -m` eq "sparc64\n"
         # added in 2000 by commit cb434fcc98ac25f5:
@@ -3083,15 +3269,8 @@ EOPATCH
     }
 
     if ($major < 10) {
-        if (!extract_from_file('ext/DB_File/DB_File.xs',
-                               qr!^#else /\* Berkeley DB Version > 2 \*/$!)) {
-            # This DB_File.xs is really too old to patch up.
-            # Skip DB_File, unless we're invoked with an explicit -Unoextensions
-            if (!exists $defines{noextensions}) {
-                $defines{noextensions} = 'DB_File';
-            } elsif (defined $defines{noextensions}) {
-                $defines{noextensions} .= ' DB_File';
-            }
+        if ($unfixable_db_file) {
+            # Nothing we can do.
         } elsif (!extract_from_file('ext/DB_File/DB_File.xs',
                                     qr/^#ifdef AT_LEAST_DB_4_1$/)) {
             # This line is changed by commit 3245f0580c13b3ab