X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a9b1bbfe0792c586f7e5c9b8e9525db88a97089a..ea319c81d6264975e581fc37c96a23a66e426632:/Porting/bisect-runner.pl diff --git a/Porting/bisect-runner.pl b/Porting/bisect-runner.pl index ea1534b..360c186 100755 --- a/Porting/bisect-runner.pl +++ b/Porting/bisect-runner.pl @@ -4,29 +4,22 @@ use strict; use Getopt::Long qw(:config bundling no_auto_abbrev); use Pod::Usage; use Config; -use Carp; +use File::Temp qw(tempdir); +use File::Spec; my @targets - = qw(config.sh config.h miniperl lib/Config.pm Fcntl perl test_prep); - -my $cpus; -if (open my $fh, '<', '/proc/cpuinfo') { - while (<$fh>) { - ++$cpus if /^processor\s+:\s+\d+$/; - } -} elsif (-x '/sbin/sysctl') { - $cpus = 1 + $1 if `/sbin/sysctl hw.ncpu` =~ /^hw\.ncpu: (\d+)$/; -} elsif (-x '/usr/bin/getconf') { - $cpus = 1 + $1 if `/usr/bin/getconf _NPROCESSORS_ONLN` =~ /^(\d+)$/; -} + = qw(none config.sh config.h miniperl lib/Config.pm Fcntl perl test_prep); my %options = ( - jobs => defined $cpus ? $cpus + 1 : 2, 'expect-pass' => 1, 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; @@ -45,28 +38,36 @@ 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', + 'target=s', 'make=s', 'jobs|j=i', 'crash', 'expect-pass=i', 'expect-fail' => sub { $options{'expect-pass'} = 0; }, - 'clean!', 'one-liner|e=s', 'c', 'l', 'w', 'match=s', + 'clean!', 'one-liner|e=s@', 'c', 'l', 'w', 'match=s', 'no-match=s' => sub { $options{match} = $_[1]; $options{'expect-pass'} = 0; }, - 'force-manifest', 'force-regen', 'test-build', 'validate', - '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', + 'module=s', 'with-module=s', 'cpan-config-dir=s', + 'A=s@', 'D=s@' => sub { my (undef, $val) = @_; if ($val =~ /\A([^=]+)=(.*)/s) { @@ -82,14 +83,51 @@ unless(GetOptions(\%options, pod2usage(exitval => 255, verbose => 1); } -my ($target, $j, $match) = @options{qw(target jobs match)}; +my ($target, $match) = @options{qw(target match)}; @ARGV = ('sh', '-c', 'cd t && ./perl TEST base/*.t') if $options{validate} && !@ARGV; pod2usage(exitval => 0, verbose => 2) if $options{usage}; + +# This needs to be done before the next arguments check, as it's populating +# @ARGV +if (defined $target && $target =~ /\.t\z/) { + # t/TEST don't have a reliable way to run the test script under valgrind + # The $ENV{VALGRIND} code was only added after v5.8.0, and is more + # geared to logging than to exiting on failure if errors are found. + # I guess one could fudge things by replacing the symlink t/perl with a + # wrapper script which invokes valgrind, but leave doing that until + # someone needs it. (If that's you, then patches welcome.) + foreach (qw(valgrind match validate test-build one-liner)) { + die_255("$0: Test-case targets can't be run with --$_") + if $options{$_}; + } + die_255("$0: Test-case targets can't be combined with an explicit test") + if @ARGV; + + # Needing this unless is a smell suggesting that this implementation of + # test-case targets is not really in the right place. + unless ($options{'check-args'}) { + # The top level sanity tests refuse to start or end a test run at a + # revision which skips, hence this test ensures reasonable sanity at + # automatically picking a suitable start point for both normal operation + # and --expect-fail + skip("Test case $target is not a readable file") + unless -f $target && -r _; + } + + # t/TEST runs from and takes pathnames relative to t/, so need to strip + # out a leading t, or add ../ otherwise + unless ($target =~ s!\At/!!) { + $target = "../$target"; + } + @ARGV = ('sh', '-c', "cd t && ./perl TEST " . quotemeta $target); + $target = 'test_prep'; +} + pod2usage(exitval => 255, verbose => 1) - unless @ARGV || $match || $options{'test-build'} || defined $options{'one-liner'}; + unless @ARGV || $match || $options{'test-build'} || defined $options{'one-liner'} || defined $options{module}; pod2usage(exitval => 255, verbose => 1) if !$options{'one-liner'} && ($options{l} || $options{w}); @@ -104,21 +142,33 @@ bisect.pl - use git bisect to pinpoint changes =head1 SYNOPSIS - # When did this become an error? - .../Porting/bisect.pl -e 'my $a := 2;' - # When did this stop being an error? - .../Porting/bisect.pl --expect-fail -e '1 // 2' - # When did this stop matching? - .../Porting/bisect.pl --match '\b(?:PL_)hash_seed_set\b' - # When did this start matching? - .../Porting/bisect.pl --expect-fail --match '\buseithreads\b' - # When did this test program stop working? - .../Porting/bisect.pl -- ./perl -Ilib ../test_prog.pl - # When did this first become valid syntax? - .../Porting/bisect.pl --target=miniperl --end=v5.10.0 \ - --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 become an error? + .../Porting/bisect.pl -e 'my $a := 2;' + # When did this stop being an error? + .../Porting/bisect.pl --expect-fail -e '1 // 2' + # When did this test start failing? + .../Porting/bisect.pl --target t/op/sort.t + # When were all lines matching this pattern removed from all files? + .../Porting/bisect.pl --match '\b(?:PL_)hash_seed_set\b' + # When was some line matching this pattern added to some file? + .../Porting/bisect.pl --expect-fail --match '\buseithreads\b' + # When did this test program stop exiting 0? + .../Porting/bisect.pl -- ./perl -Ilib ../test_prog.pl + # When did this test program start crashing (any signal or coredump)? + .../Porting/bisect.pl --crash -- ./perl -Ilib ../test_prog.pl + # When did this first become valid syntax? + .../Porting/bisect.pl --target=miniperl --end=v5.10.0 \ + --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 + # When did these cpan modules start failing to compile/pass tests? + .../Porting/bisect.pl --module=autobox,Moose + # When did this code stop working in blead with these modules? + .../Porting/bisect.pl --with-module=Moose,Moo -e 'use Moose; 1;' + # Like the above 2 but with custom CPAN::MyConfig + .../Porting/bisect.pl --module=Moo --cpan-config-dir=/home/blah/custom/ =head1 DESCRIPTION @@ -157,15 +207,36 @@ earliest stable perl version on which the test case passes, check that it fails on blead, and then use F with C to find the commit which caused the failure. +Many of perl's own test scripts exit 0 even if their TAP reports test +failures, and some need particular setup (such as running from the right +directory, or adding C<-T> to the command line). Hence if you want to bisect +a test script, you can specify it with the I<--target> option, and it will +be invoked using F which performs all the setup, and exits non-zero +if the TAP reports failures. This works for any file ending C<.t>, so you can +use it with a file outside of the working checkout, for example to test a +particular version of a test script, as a path inside the repository will +(of course) be testing the version of the script checked out for the current +revision, which may be too early to have the test you are interested in. + Because the test case is the complete argument to C, it is easy to run something other than the F built, if necessary. If you need to run -the perl built, you'll probably need to invoke it as C<./perl -Ilib ...> - -You need a clean checkout to run a bisect, and you can't use the checkout -which contains F (because C) will check out -a revision before F was added, which -C needs). If your working checkout is called F, the -simplest solution is to make a local clone, and run from that. I: +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 then it +will have C<./perl> <-Ilib> (or C<./miniperl>) prepended to it. + +You need a clean checkout to run a bisect. You can use the checkout +containing F if you wish - in this case +F will copy F to a temporary +file generated by C. If doing this, beware that when +the bisect ends (or you abort it) then your checkout is no longer at +C, so you will need to C before restarting, to +get the current version of F again. It's often easier +either to copy F and F to +another directory (I F<~/bin>, if you have one), or to create a second +git repository for running bisect. To create a second local repository, if +your working checkout is called F, a simple solution is to make a +local clone, and run from that. I: cd .. git clone perl perl2 @@ -188,10 +259,13 @@ If your F is old enough you can override this with C<-Unoextensions>. Earliest revision to test, as a I (a tag, commit or anything else C understands as a revision). If not specified, F 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 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. The default is to search from 5.002 to the most recent tagged stable +release (v5.18.0 at the time of writing). If F 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 * @@ -211,6 +285,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> @@ -260,6 +342,14 @@ is automatically substituted. For very old Fs, C is run, as there is no target provided to just get things ready, and for 5.004 and earlier the tests run very quickly. +=item * + +A file ending C<.t> + +Build everything needed to run the tests, and then run this test script using +F. This is actually implemented internally by using the target +I, and setting the test case to "sh", "-c", "cd t && ./TEST ..." + =back =item * @@ -276,7 +366,8 @@ This prepends C<./perl -Ilib -e 'code to run'> to the test case given, or F<./miniperl> if I is C. (Usually you'll use C<-e> instead of providing a test case in the -non-option arguments to F) +non-option arguments to F. You can repeat C<-e> on the command +line, just like you can with C) C<-E> intentionally isn't supported, as it's an error in 5.8.0 and earlier, which interferes with detecting errors in the example code itself. @@ -317,17 +408,30 @@ revision. The bisect run will find the first commit where it passes. =item * --Dnoextensions=Encode +--crash + +Treat any non-crash as success, any crash as failure. (Crashing defined +as exiting with a signal or a core dump.) + +=item * + +-D I =item * --Uusedevel +-U I =item * --Accflags=-DNO_MATHOMS +-A I + +Arguments (C<-A>, C<-D>, C<-U>) to pass to F. For example, + + -Dnoextensions=Encode + -Uusedevel + -Accflags=-DNO_MATHOMS -Arguments to pass to F. Repeated C<-A> arguments are passed +Repeated C<-A> arguments are passed through as is. C<-D> and C<-U> are processed in order, and override previous settings for the same parameter. F emulates C<-Dnoextensions> when F itself does not provide it, as it's @@ -350,10 +454,11 @@ to use F in place of the system F. -j I -Number of C jobs to run in parallel. If F exists and -can be parsed, or F exists and reports C, or -F exists and reports C<_NPROCESSORS_ONLN> defaults to 1 + -I. Otherwise defaults to 2. +Number of C jobs to run in parallel. A value of 0 suppresses +parallelism. If F exists and can be parsed, or F +exists and reports C, or F exists and reports +C<_NPROCESSORS_ONLN> defaults to 1 + I. On HP-UX with the +system make defaults to 0, otherwise defaults to 2. =item * @@ -399,6 +504,24 @@ C<--no-match ...> is implemented as C<--expect-fail --match ...> =item * +--valgrind + +Run the test program under C. If you need to test for memory +errors when parsing invalid programs, the default parser fail exit code of +255 will always override C, so try putting the test case invalid +code inside a I C, so that the perl interpreter will exit with 0. +(Be sure to check the output of $@, to avoid missing mistakes such as +unintended C failures due to incorrect C<@INC>) + +Specifically, this option prepends C 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 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. @@ -425,6 +548,70 @@ even link. =item * +--module module1,module2,... + +Install this (or these) module(s), die when it (the last of those) +cannot be updated to the current version. + +Misnomer. the argument can be any argument that can be passed to CPAN +shell's install command. B: since we only have the uptodate +command to verify that an install has taken place, we are unable to +determine success for arguments like +MSCHWERN/Test-Simple-1.005000_005.tar.gz. + +In so far, it is not such a misnomer. + +Note that this and I<--with-module> will both require a C. +If F<$ENV{HOME}/.cpan/CPAN/MyConfig.pm> does not exist, a CPAN shell will +be started up for you so you can configure one. Feel free to let +CPAN pick defaults for you. Enter 'quit' when you are done, and +then everything should be all set. Alternatively, you may +specify a custom C by using I<--cpan-config-dir>. + +Also, if you want to bisect a module that needs a display (like +TK) and you don't want random screens appearing and disappearing +on your computer while you're working, you can do something like +this: + +In a terminal: + + $ while true; do date ; if ! ps auxww | grep -v grep \ + | grep -q Xvfb; then Xvfb :121 & fi; echo -n 'sleeping 60 '; \ + sleep 60; done + +And then: + + DISPLAY=":121" .../Porting/bisect.pl --module=TK + +(Some display alternatives are vncserver and Xnest.) + +=item * + +--with-module module1,module2,... + +Like I<--module> above, except this simply installs the requested +modules and they can then be used in other tests. + +For example: + + .../Porting/bisect.pl --with-module=Moose -e 'use Moose; ...' + +=item * + +--cpan-config-dir /home/blah/custom + +If defined, this will cause L to look for F inside of +the specified directory, instead of using the default config of +F<$ENV{HOME}/.cpan/>. + +If no default config exists, a L shell will be fired up for you to +configure things. Letting L automatically configure things for you +should work well enough. You probably want to choose I instead of +I if it asks. When you're finished with configuration, just +type I and hit I and the bisect should continue. + +=item * + --force-manifest By default, a build will "skip" if any files listed in F are not @@ -453,6 +640,92 @@ 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 +version dependent basis to get the build to complete. Normally it defers +doing this as long as possible - C<.SH> files aren't patched until after +F is run, and C and C code isn't patched until after +F is built. If C<--all-fixups> is specified, all the fixups are +done before running C. In rare cases adding this may cause a +bisect to abort, because an inapplicable patch or other fixup is attempted +for a revision which would usually have already Iped. If this happens, +please report it as a bug, giving the OS and problem revision. + +=item * + +--early-fixup file + +=item * + +--late-fixup file + +Specify a file containing a patch or other fixup for the source code. The +action to take depends on the first line of the fixup file + +=over 4 + +=item * + +C<#!perl> + +If the first line starts C<#!perl> then the file is run using C<$^X> + +=item * + +C<#!/absolute/path> + +If a shebang line is present the file is executed using C + +=item * + +C =~ /I/> + +=item * + +C !~ /I/> + +If I does not exist then the fixup file's contents are ignored. +Otherwise, for C<=~>, if it contains a line matching I, then the +file is fed to C on standard input. For C<=~>, the patch is +applied if no lines match the pattern. + +As the empty pattern in Perl is a special case (it matches the most recent +successful match) which is not useful here, the treatment of an empty pattern +is special-cased. C =~ //> applies the patch if filename is +present. C !~ //> applies the patch if filename missing. This +makes it easy to unconditionally apply patches to files, and to use a patch +as a way of creating a new file. + +=item * + +Otherwise, the file is assumed to be a patch, and always applied. + +=back + +Is are applied before F<./Configure> is run. Is are +applied just after F<./Configure> is run. + +These options can be specified more than once. I is actually expanded +as a glob pattern. Globs that do not match are errors, as are missing files. + +=item * + --no-clean Tell F not to clean up after the build. This allows one @@ -465,12 +738,12 @@ Passing this to F will likely cause the bisect to fail badly. --validate -Test that all stable revisions can be built. By default, attempts to build -I, I .. I (or I 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, then tagged stable releases in reverse order down to +I (or I 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 $]"' @@ -489,16 +762,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 does B -prepend C<./perl> to the test case, a I<#!> line specifying an external -F binary will cause the test case to always run with I F, -not the F 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 binary will cause the test case to always run with I +F, not the F 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. F defaults this to I, +but F will default it to the most recent stable release. + +=item * + --usage =item * @@ -515,7 +796,44 @@ Display the usage information and exit. =cut -die "$0: Can't build $target" if defined $target && !grep {@targets} $target; +# Ensure we always exit with 255, to cause git bisect to abort. +sub croak_255 { + my $message = join '', @_; + if ($message =~ /\n\z/) { + print STDERR $message; + } else { + my (undef, $file, $line) = caller 1; + print STDERR "@_ at $file line $line\n"; + } + exit 255; +} + +sub die_255 { + croak_255(@_); +} + +die_255("$0: Can't build $target") + if defined $target && !grep {@targets} $target; + +foreach my $phase (qw(early late)) { + next unless $options{"$phase-fixup"}; + my $bail_out; + require File::Glob; + my @expanded; + foreach my $glob (@{$options{"$phase-fixup"}}) { + my @got = File::Glob::bsd_glob($glob); + push @expanded, @got ? @got : $glob; + } + @expanded = sort @expanded; + $options{"$phase-fixup"} = \@expanded; + foreach (@expanded) { + unless (-f $_) { + print STDERR "$phase-fixup '$_' is not a readable file\n"; + ++$bail_out; + } + } + exit 255 if $bail_out; +} unless (exists $defines{cc}) { # If it fails, the heuristic of 63f9ec3008baf7d6 is noisy, and hence @@ -526,7 +844,7 @@ unless (exists $defines{cc}) { $defines{cc} = (`ccache -V`, $?) ? 'cc' : 'ccache cc'; } -$j = "-j$j" if $j =~ /\A\d+\z/; +my $j = $options{jobs} ? "-j$options{jobs}" : ''; if (exists $options{make}) { if (!exists $defines{make}) { @@ -544,7 +862,7 @@ if (exists $options{make}) { sub open_or_die { my $file = shift; my $mode = @_ ? shift : '<'; - open my $fh, $mode, $file or croak("Can't open $file: $!"); + open my $fh, $mode, $file or croak_255("Can't open $file: $!"); ${*$fh{SCALAR}} = $file; return $fh; } @@ -552,8 +870,78 @@ sub open_or_die { sub close_or_die { my $fh = shift; return if close $fh; - croak("Can't close: $!") unless ref $fh eq 'GLOB'; - croak("Can't close ${*$fh{SCALAR}}: $!"); + croak_255("Can't close: $!") unless ref $fh eq 'GLOB'; + croak_255("Can't close ${*$fh{SCALAR}}: $!"); +} + +sub system_or_die { + my $command = '{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 { @@ -573,11 +961,11 @@ sub edit_file { local $/; my $fh = open_or_die($file); my $orig = <$fh>; - die "Can't read $file: $!" unless defined $orig && close $fh; + die_255("Can't read $file: $!") unless defined $orig && close $fh; my $new = $munger->($orig); return if $new eq $orig; $fh = open_or_die($file, '>'); - print $fh $new or die "Can't print to $file: $!"; + print $fh $new or die_255("Can't print to $file: $!"); close_or_die($fh); } @@ -614,7 +1002,7 @@ sub ud2cd { } if (!length $diff_in) { - die "That didn't seem to be a diff"; + die_255("That didn't seem to be a diff"); } if ($diff_in =~ /\A\*\*\* /ms) { @@ -634,11 +1022,11 @@ sub ud2cd { } $diff_in =~ s/\A([^\n]+\n?)//ms; my $line = $1; - die "Can't parse '$line'" unless $line =~ s/\A--- /*** /ms; + die_255("Can't parse '$line'") unless $line =~ s/\A--- /*** /ms; $diff_out .= $line; $diff_in =~ s/\A([^\n]+\n?)//ms; $line = $1; - die "Can't parse '$line'" unless $line =~ s/\A\+\+\+ /--- /ms; + die_255("Can't parse '$line'") unless $line =~ s/\A\+\+\+ /--- /ms; $diff_out .= $line; # Loop for hunks @@ -651,7 +1039,8 @@ sub ud2cd { my $to_end = $to_start + $to_count - 1; my ($from_out, $to_out, $has_from, $has_to, $add, $delete); while (length $diff_in && ($from_count || $to_count)) { - die "Confused in $hunk" unless $diff_in =~ s/\A([^\n]*)\n//ms; + die_255("Confused in $hunk") + unless $diff_in =~ s/\A([^\n]*)\n//ms; my $line = $1; $line = ' ' unless length $line; if ($line =~ /^ .*/) { @@ -670,14 +1059,14 @@ sub ud2cd { push @$add, $1; --$to_count; } else { - die "Can't parse '$line' as part of hunk $hunk"; + die_255("Can't parse '$line' as part of hunk $hunk"); } } process_hunk(\$from_out, \$to_out, \$has_from, \$has_to, $delete, $add); - die "No lines in hunk $hunk" + die_255("No lines in hunk $hunk") unless length $from_out || length $to_out; - die "No changes in hunk $hunk" + die_255("No changes in hunk $hunk") unless $has_from || $has_to; $diff_out .= "***************\n"; $diff_out .= "*** $from_start,$from_end ****\n"; @@ -696,7 +1085,7 @@ sub ud2cd { if (!defined $use_context) { my $version = `patch -v 2>&1`; - die "Can't run `patch -v`, \$?=$?, bailing out" + die_255("Can't run `patch -v`, \$?=$?, bailing out") unless defined $version; if ($version =~ /Free Software Foundation/) { $use_context = 0; @@ -704,6 +1093,10 @@ sub ud2cd { # The system patch is older than Linux, and probably older than # Windows NT. $use_context = 1; + } elsif ($version =~ /Header: patch\.c,v.*\babhinav\b/) { + # Thank you HP. No, we have no idea *which* version this is: + # $Header: patch.c,v 76.1.1.2.1.3 2001/12/03 12:24:52 abhinav Exp $ + $use_context = 1; } else { # Don't know. $use_context = 0; @@ -718,25 +1111,25 @@ 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); - open my $fh, '|-', 'patch', '-p1' or die "Can't run patch: $!"; + open my $fh, '|-', 'patch', '-p1' or die_255("Can't run patch: $!"); print $fh $patch_to_use; return if close $fh; print STDERR "Patch is <<'EOPATCH'\n${patch}EOPATCH\n"; print STDERR "\nConverted to a context diff <<'EOCONTEXT'\n${patch_to_use}EOCONTEXT\n" if $patch_to_use ne $patch; - die "Can't $what$files: $?, $!"; + die_255("Can't $what$files: $?, $!"); } sub apply_commit { my ($commit, @files) = @_; my $patch = `git show $commit @files`; if (!defined $patch) { - die "Can't get commit $commit for @files: $?" if @files; - die "Can't get commit $commit: $?"; + die_255("Can't get commit $commit for @files: $?") if @files; + die_255("Can't get commit $commit: $?"); } apply_patch($patch, "patch $commit", @files ? " for @files" : ''); } @@ -745,32 +1138,33 @@ sub revert_commit { my ($commit, @files) = @_; my $patch = `git show -R $commit @files`; if (!defined $patch) { - die "Can't get revert commit $commit for @files: $?" if @files; - die "Can't get revert commit $commit: $?"; + die_255("Can't get revert commit $commit for @files: $?") if @files; + die_255("Can't get revert commit $commit: $?"); } apply_patch($patch, "revert $commit", @files ? " for @files" : ''); } sub checkout_file { my ($file, $commit) = @_; - $commit ||= 'blead'; + $commit ||= $options{gold} || 'blead'; system "git show $commit:$file > $file ; + return if $line =~ $run_with_our_perl; if (!-x $file) { - die "$file is not executable. + die_255("$file is not executable. system($file, ...) is always going to fail. -Bailing out"; +Bailing out"); } - my $fh = open_or_die($file); - my $line = <$fh>; return unless $line =~ m{\A#!(/\S+/perl\S*)\s}; - die "$file will always be run by $1 + die_255("$file will always be run by $1 It won't be tested by the ./perl we build. If you intended to run it with that perl binary, please change your test case to @@ -785,14 +1179,14 @@ test case to [You may also need to add -- before ./perl to prevent that -Ilib as being parsed as an argument to bisect.pl] -Bailing out"; +Bailing out"); } 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}, + }, @_); + $ret &= 0xff if $options{crash}; + report_and_exit(!$ret, 'zero exit from', 'non-zero exit from', "@_"); +} + sub match_and_exit { my ($target, @globs) = @_; my $matches = 0; @@ -847,7 +1249,7 @@ sub match_and_exit { while (<$fh>) { if ($_ =~ $re) { ++$matches; - if (tr/\t\r\n -~\200-\377//c) { + if (/[^[:^cntrl:]\h\v]/) { # Matches non-spacing non-C1 controls print "Binary file $file matches\n"; } else { $_ .= "\n" unless /\n\z/; @@ -857,17 +1259,20 @@ 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); } # Not going to assume that system perl is yet new enough to have autodie -system 'git clean -dxf 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'}) { + patch_SH(); + patch_C(); + patch_ext(); +} +apply_fixups($options{'early-fixup'}); # if Encode is not needed for the test, you can speed up the bisect by # excluding it from the runs with -Dnoextensions=Encode @@ -906,16 +1332,22 @@ patch_hints(); # bail out pretty early on. Configure won't let us override libswanted, but it # will let us override the entire libs list. +foreach (@{$options{A}}) { + push @paths, $1 if /^libpth=(.*)/s; +} + unless (extract_from_file('Configure', 'ignore_versioned_solibs')) { # Before 1cfa4ec74d4933da, so force the libs list. my @libs; # This is the current libswanted list from Configure, less the libs removed # by current hints/linux.sh - foreach my $lib (qw(sfio socket inet nsl nm ndbm gdbm dbm db malloc dl dld + foreach my $lib (qw(sfio socket inet nsl nm ndbm gdbm dbm db malloc dl ld sun m crypt sec util c cposix posix ucb BSD)) { foreach my $dir (@paths) { - next unless -f "$dir/lib$lib.so"; + # Note the wonderful consistency of dot-or-not in the config vars: + next unless -f "$dir/lib$lib.$Config{dlext}" + || -f "$dir/lib$lib$Config{lib_ext}"; push @libs, "-l$lib"; last; } @@ -946,39 +1378,50 @@ foreach my $key (sort keys %defines) { } push @ARGS, map {"-A$_"} @{$options{A}}; -# 1); + + push @ARGS, "-Dprefix=$prefix"; + push @ARGS, "-Uversiononly", "-Dinstallusrbinperl=n"; } -waitpid $pid, 0 - or die "wait for Configure, pid $pid failed: $!"; -patch_SH(); +# 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'}); if (-f 'config.sh') { # Emulate noextensions if Configure doesn't support it. fake_noextensions() if $major < 10 && $defines{noextensions}; - system './Configure -S 1, + ) or die $!; + + # Don't ever stop to ask the user for input + $ENV{AUTOMATED_TESTING} = 1; + $ENV{PERL_MM_USE_DEFAULT} = 1; + + # Don't let these interfere with our cpan installs + delete $ENV{PERL_MB_OPT}; + delete $ENV{PERL_MM_OPT}; + + # Make sure we load up our CPAN::MyConfig and then + # override the build_dir so we have a fresh one + # every build + my $cdir = $options{'cpan-config-dir'} + || File::Spec->catfile($ENV{HOME},".cpan"); + + my @cpanshell = ( + "$prefix/bin/perl", + "-I", "$cdir", + "-MCPAN::MyConfig", + "-MCPAN", + "-e","\$CPAN::Config->{build_dir}=q{$bdir};", + "-e", + ); + + for (@m) { + s/-/::/g if /-/ and !m|/|; + } + my $install = join ",", map { "'$_'" } @m; + my $last = $m[-1]; + my $shellcmd = "install($install); die unless CPAN::Shell->expand(Module => '$last')->uptodate;"; + + if ($options{module}) { + run_report_and_exit(@cpanshell, $shellcmd); + } else { + my $ret = run_with_options({setprgp => $options{setpgrp}, + timeout => $options{timeout}, + }, @cpanshell, $shellcmd); + $ret &= 0xff if $options{crash}; + + # Failed? Give up + if ($ret) { + report_and_exit(!$ret, 'zero exit from', 'non-zero exit from', "@_"); + } + } +} + my $expected_file_found = $expected_file =~ /perl$/ ? -x $expected_file : -r $expected_file; @@ -1043,12 +1543,12 @@ if ($expected_file_found && $expected_file eq 't/perl') { undef $expected_file_found; my $link = readlink $expected_file; warn "'t/perl' => '$link', not 'perl'"; - die "Could not realink t/perl: $!" unless defined $link; + die_255("Could not realink t/perl: $!") unless defined $link; } } 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"); @@ -1058,13 +1558,33 @@ match_and_exit($real_target, @ARGV) if $match; if (defined $options{'one-liner'}) { my $exe = $target =~ /^(?:perl$|test)/ ? 'perl' : 'miniperl'; - unshift @ARGV, '-e', $options{'one-liner'}; + unshift @ARGV, map {('-e', $_)} @{$options{'one-liner'}}; foreach (qw(c l w)) { unshift @ARGV, "-$_" if $options{$_}; } 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}) { @@ -1078,9 +1598,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); ############################################################################ # @@ -1121,12 +1639,12 @@ sub force_manifest { while (@parts) { $path .= '/' . shift @parts; next if -d $path; - mkdir $path, 0700 or die "Can't create $path: $!"; + mkdir $path, 0700 or die_255("Can't create $path: $!"); unshift @created_dirs, $path; } $fh = open_or_die($pathname, '>'); close_or_die($fh); - chmod 0, $pathname or die "Can't chmod 0 $pathname: $!"; + chmod 0, $pathname or die_255("Can't chmod 0 $pathname: $!"); } return \@missing, \@created_dirs; } @@ -1152,10 +1670,10 @@ sub force_manifest_cleanup { push @errors, "Added file $file had sized changed by Configure to $size"; } - unlink $file or die "Can't unlink $file: $!"; + unlink $file or die_255("Can't unlink $file: $!"); } foreach my $dir (@$created_dirs) { - rmdir $dir or die "Can't rmdir $dir: $!"; + rmdir $dir or die_255("Can't rmdir $dir: $!"); } skip("@errors") if @errors; @@ -1218,8 +1736,8 @@ EOPATCH my $mips = extract_from_file('Configure', qr!(''\) if (?:\./)?mips; then)!); # This is part of perl-5.001n. It's needed, to add -L/usr/local/lib to - # theld flags if libraries are found there. It shifts the code to set up - # libpth earlier, and then adds the code to add libpth entries to + # the ld flags if libraries are found there. It shifts the code to set + # up libpth earlier, and then adds the code to add libpth entries to # ldflags # mips was changed to ./mips in ecfc54246c2a6f42, perl5.000 patch.0g apply_patch(sprintf <<'EOPATCH', $mips); @@ -1360,6 +1878,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 @@ -1420,13 +1965,13 @@ EOPATCH edit_file('Configure', sub { my $code = shift; $code =~ s/(optstr = ")([^"]+";\s*# getopt-style specification)/$1A:$2/ - or die "Substitution failed"; + or die_255("Substitution failed"); $code =~ s!^(: who configured the system)! touch posthint.sh . ./posthint.sh $1!ms - or die "Substitution failed"; + or die_255("Substitution failed"); return $code; }); apply_patch(<<'EOPATCH'); @@ -1585,7 +2130,7 @@ eval "$2=$tval"' EOC $code =~ s/\n: is a C symbol defined\?\n.*?\neval "\$2=\$tval"'\n\n/$fixed/sm - or die "substitution failed"; + or die_255("substitution failed"); return $code; }); } @@ -1845,7 +2390,7 @@ EOPATCH } elsif(!extract_from_file('hints/linux.sh', qr/^sparc-linux\)$/)) { my $fh = open_or_die('hints/linux.sh', '>>'); - print $fh <<'EOT' or die $!; + print $fh <<'EOT' or die_255($!); case "`uname -m`" in sparc*) @@ -1860,6 +2405,11 @@ EOT } } } + } elsif ($^O eq 'solaris') { + if (($major == 13 || $major == 14) + && extract_from_file('hints/solaris_2.sh', qr/getconfldllflags/)) { + apply_commit('c80bde4388070c45'); + } } } @@ -1914,6 +2464,29 @@ index f61d0db..6097954 100644 EOPATCH } + if ($major == 15 && $^O !~ /^(linux|darwin|.*bsd)$/ + && extract_from_file('Makefile.SH', qr/^V.* \?= /)) { + # Remove the GNU-make-ism (which the BSD makes also support, but + # most other makes choke on) + apply_patch(<<'EOPATCH'); +diff --git a/Makefile.SH b/Makefile.SH +index 94952bd..13e9001 100755 +--- a/Makefile.SH ++++ b/Makefile.SH +@@ -338,8 +338,8 @@ linux*|darwin) + $spitshell >>$Makefile </dev/null ++VALGRIND = valgrind ++VG_TEST = ./perl -e 1 2>/dev/null + + !GROK!THIS! + ;; +EOPATCH + } + if ($major == 11) { if (extract_from_file('patchlevel.h', qr/^#include "unpushed\.h"/)) { @@ -2369,6 +2942,26 @@ EOPATCH } } + if ($major < 4 && $^O eq 'hpux' + && extract_from_file('sv.c', qr/i = _filbuf\(/)) { + apply_patch(<<'EOPATCH'); +diff --git a/sv.c b/sv.c +index a1f1d60..0a806f1 100644 +--- a/sv.c ++++ b/sv.c +@@ -2641,7 +2641,7 @@ I32 append; + + FILE_cnt(fp) = cnt; /* deregisterize cnt and ptr */ + FILE_ptr(fp) = ptr; +- i = _filbuf(fp); /* get more characters */ ++ i = __filbuf(fp); /* get more characters */ + cnt = FILE_cnt(fp); + ptr = FILE_ptr(fp); /* reregisterize cnt and ptr */ + + +EOPATCH + } + if ($major == 4 && extract_from_file('scope.c', qr/\(SV\*\)SSPOPINT/)) { # [PATCH] 5.004_04 +MAINT_TRIAL_1 broken when sizeof(int) != sizeof(void) # Fixes a bug introduced in 161b7d1635bc830b @@ -2407,7 +3000,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'); @@ -2724,6 +3332,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: @@ -2908,15 +3526,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 @@ -2992,9 +3603,43 @@ EOFIX } } -# Local variables: -# cperl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# +sub apply_fixups { + my $fixups = shift; + return unless $fixups; + foreach my $file (@$fixups) { + my $fh = open_or_die($file); + my $line = <$fh>; + close_or_die($fh); + if ($line =~ /^#!perl\b/) { + system $^X, $file + and die_255("$^X $file failed: \$!=$!, \$?=$?"); + } elsif ($line =~ /^#!(\/\S+)/) { + system $file + and die_255("$file failed: \$!=$!, \$?=$?"); + } else { + if (my ($target, $action, $pattern) + = $line =~ m#^(\S+) ([=!])~ /(.*)/#) { + if (length $pattern) { + next unless -f $target; + if ($action eq '=') { + next unless extract_from_file($target, $pattern); + } else { + next if extract_from_file($target, $pattern); + } + } else { + # Avoid the special case meaning of the empty pattern, + # and instead use this to simply test for the file being + # present or absent + if ($action eq '=') { + next unless -f $target; + } else { + next if -f $target; + } + } + } + system_or_die("patch -p1 <$file"); + } + } +} + # ex: set ts=8 sts=4 sw=4 et: