X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/12641c3bc3b66b6b08b7feeca89a7cc24aa0fe9c..082484dd2f490fcf9789977adbb43e81f758edff:/Porting/bisect-runner.pl diff --git a/Porting/bisect-runner.pl b/Porting/bisect-runner.pl index b3963a5..81ccd90 100755 --- a/Porting/bisect-runner.pl +++ b/Porting/bisect-runner.pl @@ -6,7 +6,7 @@ use Pod::Usage; use Config; my @targets - = qw(config.sh config.h miniperl lib/Config.pm Fcntl perl test_prep); + = qw(none config.sh config.h miniperl lib/Config.pm Fcntl perl test_prep); my %options = ( @@ -60,7 +60,8 @@ unless(GetOptions(\%options, $options{match} = $_[1]; $options{'expect-pass'} = 0; }, - 'force-manifest', 'force-regen', 'test-build', 'validate', + '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@', @@ -220,6 +221,14 @@ this should be one of =item * +I + +Don't build anything - just run the user test case against a clean checkout. +Using this gives a couple of features that a plain C can't +offer - automatic start revision detection, and test case C<--timeout>. + +=item * + I Just run F<./Configure> @@ -487,6 +496,21 @@ C<--expect-pass=0> is equivalent to C<--expect-fail>. I<1> is the default. =item * +--timeout I + +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 +just before C-ing the user testcase. The default is not to set the +process group, unless a timeout is used. + +=item * + --all-fixups F will minimally patch various files on a platform and @@ -716,18 +740,63 @@ sub run_with_options { 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}: $!"; + 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: $!"); + 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 $?; } @@ -898,7 +967,7 @@ sub apply_patch { my ($patch, $what, $files) = @_; $what = 'patch' unless defined $what; unless (defined $files) { - $patch =~ m!^--- a/(\S+)\n\+\+\+ b/\1!sm; + $patch =~ m!^--- [ab]/(\S+)\n\+\+\+ [ba]/\1!sm; $files = " $1"; } my $patch_to_use = placate_patch_prog($patch); @@ -973,7 +1042,7 @@ sub clean { if ($options{clean}) { # Needed, because files that are build products in this checked out # version might be in git in the next desired version. - system 'git clean -dxf $options{setpgrp}, + timeout => $options{timeout}, + }, @_); report_and_exit(!$ret, 'zero exit from', 'non-zero exit from', "@_"); } @@ -1054,6 +1125,9 @@ system_or_die('git clean -dxf'); if (!defined $target) { match_and_exit(undef, @ARGV) if $match; $target = 'test_prep'; +} elsif ($target eq 'none') { + match_and_exit(undef, @ARGV) if $match; + run_report_and_exit(@ARGV); } skip('no Configure - is this the //depot/perlext/Compiler branch?') @@ -1585,6 +1659,33 @@ index 53649d5..0635a6e 100755 EOPATCH } + if ($major == 4 && extract_from_file('Configure', qr/^d_gethbynam=/)) { + # Fixes a bug introduced in 4599a1dedd47b916 + apply_commit('3cbc818d1d0ac470'); + } + + if ($major == 4 && extract_from_file('Configure', + qr/gethbadd_addr_type=`echo \$gethbadd_addr_type/)) { + # Fixes a bug introduced in 3fd537d4b944bc7a + apply_commit('6ff9219da6cf8cfd'); + } + + if ($major == 4 && extract_from_file('Configure', + qr/^pthreads_created_joinable=/)) { + # Fix for bug introduced in 52e1cb5ebf5e5a8c + # Part of commit ce637636a41b2fef + edit_file('Configure', sub { + my $code = shift; + $code =~ s{^pthreads_created_joinable=''} + {d_pthreads_created_joinable=''}ms + or die_255("Substitution failed"); + $code =~ s{^pthreads_created_joinable='\$pthreads_created_joinable'} + {d_pthreads_created_joinable='\$d_pthreads_created_joinable'}ms + or die_255("Substitution failed"); + return $code; + }); + } + if ($major < 5 && extract_from_file('Configure', qr!if \$cc \$ccflags try\.c -o try >/dev/null 2>&1; then!)) { # Analogous to the more general fix of dfe9444ca7881e71