In bisect-runner.pl, run_report_and_exit() now uses run_with_options().

[perl5.git] / Porting / bisect-runner.pl

diff --git a/Porting/bisect-runner.pl b/Porting/bisect-runner.pl
index ee3f9d5..d8172f4 100755 (executable)
--- a/Porting/bisect-runner.pl
+++ b/Porting/bisect-runner.pl
@@ -36,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; },
@@ -58,7 +62,8 @@ unless(GetOptions(\%options,
                   },
                   'force-manifest', 'force-regen', 'test-build', 'validate',
                   'all-fixups', 'early-fixup=s@', 'late-fixup=s@', 'valgrind',
-                  'check-args', 'check-shebang!', 'usage|help|?', 'A=s@',
+                  'check-args', 'check-shebang!', 'usage|help|?', 'gold=s',
+                  'A=s@',
                   'D=s@' => sub {
                       my (undef, $val) = @_;
                       if ($val =~ /\A([^=]+)=(.*)/s) {
@@ -599,6 +604,14 @@ 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 *
@@ -698,6 +711,26 @@ 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 $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}: $!";
+        }
+        { exec @_ };
+        die_255("Failed to start $name: $!");
+    }
+    waitpid $pid, 0
+        or die_255("wait for $name, pid $pid failed: $!");
+    return $?;
+}
+
 sub extract_from_file {
     my ($file, $rx, $default) = @_;
     my $fh = open_or_die($file);
@@ -900,7 +933,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");
 }
@@ -955,20 +988,25 @@ 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(undef, @_);
+    report_and_exit(!$ret, 'zero exit from', 'non-zero exit from', "@_");
+}
+
 sub match_and_exit {
     my ($target, @globs) = @_;
     my $matches = 0;
@@ -1005,7 +1043,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);
 }
@@ -1121,21 +1159,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'});
@@ -1149,13 +1179,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
 
@@ -1226,7 +1255,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");
@@ -1276,9 +1305,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);
 
 ############################################################################
 #