Porting/bisect-runner.pl

   1 #!/usr/bin/perl -w
   2 use strict;
   3
   4 use Getopt::Long qw(:config bundling);
   5
   6 my @targets = qw(miniperl lib/Config.pm perl test_prep);
   7
   8 my $target = 'test_prep';
   9 my $j = '9';
  10 my $test_should_pass = 1;
  11 my $clean = 1;
  12 my $one_liner;
  13 my $match;
  14 my $force_manifest;
  15 my $test_build;
  16 my $check_args;
  17
  18 sub usage {
  19     die "$0: [--target=...] [-j4] [--expect-pass=0|1] thing to test";
  20 }
  21
  22 unless(GetOptions('target=s' => \$target,
  23                   'jobs|j=i' => \$j,
  24                   'expect-pass=i' => \$test_should_pass,
  25                   'expect-fail' => sub { $test_should_pass = 0; },
  26                   'clean!' => \$clean, # mostly for debugging this
  27                   'one-liner|e=s' => \$one_liner,
  28                   'match=s' => \$match,
  29                   'force-manifest' => \$force_manifest,
  30                   'test-build' => \$test_build,
  31                   'check-args' => \$check_args,
  32                  )) {
  33     usage();
  34 }
  35
  36 exit 0 if $check_args;
  37
  38 my $exe = $target eq 'perl' || $target eq 'test_prep' ? 'perl' : 'miniperl';
  39 my $expected = $target eq 'test_prep' ? 'perl' : $target;
  40
  41 unshift @ARGV, "./$exe", '-Ilib', '-e', $one_liner if defined $one_liner;
  42
  43 usage() unless @ARGV || $match || $test_build;
  44
  45 die "$0: Can't build $target" unless grep {@targets} $target;
  46
  47 $j = "-j$j" if $j =~ /\A\d+\z/;
  48
  49 # Sadly, however hard we try, I don't think that it will be possible to build
  50 # modules in ext/ on x86_64 Linux before commit e1666bf5602ae794 on 1999/12/29,
  51 # which updated to MakeMaker 3.7, which changed from using a hard coded ld
  52 # in the Makefile to $(LD). On x86_64 Linux the "linker" is gcc.
  53
  54 sub extract_from_file {
  55     my ($file, $rx, $default) = @_;
  56     open my $fh, '<', $file or die "Can't open $file: $!";
  57     while (<$fh>) {
  58         my @got = $_ =~ $rx;
  59         return wantarray ? @got : $got[0]
  60             if @got;
  61     }
  62     return $default if defined $default;
  63     return;
  64 }
  65
  66 sub clean {
  67     if ($clean) {
  68         # Needed, because files that are build products in this checked out
  69         # version might be in git in the next desired version.
  70         system 'git clean -dxf';
  71         # Needed, because at some revisions the build alters checked out files.
  72         # (eg pod/perlapi.pod). Also undoes any changes to makedepend.SH
  73         system 'git reset --hard HEAD';
  74     }
  75 }
  76
  77 sub skip {
  78     my $reason = shift;
  79     clean();
  80     warn "skipping - $reason";
  81     exit 125;
  82 }
  83
  84 sub report_and_exit {
  85     my ($ret, $pass, $fail, $desc) = @_;
  86
  87     clean();
  88
  89     my $got = ($test_should_pass ? !$ret : $ret) ? 'good' : 'bad';
  90     if ($ret) {
  91         print "$got - $fail $desc\n";
  92     } else {
  93         print "$got - $pass $desc\n";
  94     }
  95
  96     exit($got eq 'bad');
  97 }
  98
  99 sub apply_patch {
 100     my $patch = shift;
 101
 102     open my $fh, '|-', 'patch' or die "Can't run patch: $!";
 103     print $fh $patch;
 104     close $fh or die "Can't patch perl.c: $?, $!";
 105 }
 106
 107 # Not going to assume that system perl is yet new enough to have autodie
 108 system 'git clean -dxf' and die;
 109
 110 if ($match) {
 111     my $matches;
 112     my $re = qr/$match/;
 113     foreach my $file (`git ls-files`) {
 114         chomp $file;
 115         open my $fh, '<', $file or die "Can't open $file: $!";
 116         while (<$fh>) {
 117             if ($_ =~ $re) {
 118                 ++$matches;
 119                 $_ .= "\n" unless /\n\z/;
 120                 print "$file: $_";
 121             }
 122         }
 123         close $fh or die "Can't close $file: $!";
 124     }
 125     report_and_exit(!$matches, 'matches for', 'no matches for', $match);
 126 }
 127
 128 skip('no Configure - is this the //depot/perlext/Compiler branch?')
 129     unless -f 'Configure';
 130
 131 # This changes to PERL_VERSION in 4d8076ea25903dcb in 1999
 132 my $major
 133     = extract_from_file('patchlevel.h',
 134                         qr/^#define\s+(?:PERL_VERSION|PATCHLEVEL)\s+(\d+)\s/,
 135                         0);
 136
 137 if ($major < 1) {
 138     if (extract_from_file('Configure',
 139                           qr/^          \*=\*\) echo "\$1" >> \$optdef;;$/)) {
 140         # This is "        Spaces now allowed in -D command line options.",
 141         # part of commit ecfc54246c2a6f42
 142         apply_patch(<<'EOPATCH');
 143 diff --git a/Configure b/Configure
 144 index 3d3b38d..78ffe16 100755
 145 --- a/Configure
 146 +++ b/Configure
 147 @@ -652,7 +777,8 @@ while test $# -gt 0; do
 148                         echo "$me: use '-U symbol=', not '-D symbol='." >&2
 149                         echo "$me: ignoring -D $1" >&2
 150                         ;;
 151 -               *=*) echo "$1" >> $optdef;;
 152 +               *=*) echo "$1" | \
 153 +                               sed -e "s/'/'\"'\"'/g" -e "s/=\(.*\)/='\1'/" >> $optdef;;
 154                 *) echo "$1='define'" >> $optdef;;
 155                 esac
 156                 shift
 157 EOPATCH
 158     }
 159     if (extract_from_file('Configure', qr/^if \$contains 'd_namlen' \$xinc\b/)) {
 160         # Configure's original simple "grep" for d_namlen falls foul of the
 161         # approach taken by the glibc headers:
 162         # #ifdef _DIRENT_HAVE_D_NAMLEN
 163         # # define _D_EXACT_NAMLEN(d) ((d)->d_namlen)
 164         #
 165         # where _DIRENT_HAVE_D_NAMLEN is not defined on Linux.
 166         # This is also part of commit ecfc54246c2a6f42
 167         apply_patch(<<'EOPATCH');
 168 diff --git a/Configure b/Configure
 169 index 3d3b38d..78ffe16 100755
 170 --- a/Configure
 171 +++ b/Configure
 172 @@ -3935,7 +4045,8 @@ $rm -f try.c
 173
 174  : see if the directory entry stores field length
 175  echo " "
 176 -if $contains 'd_namlen' $xinc >/dev/null 2>&1; then
 177 +$cppstdin $cppflags $cppminus < "$xinc" > try.c
 178 +if $contains 'd_namlen' try.c >/dev/null 2>&1; then
 179         echo "Good, your directory entry keeps length information in d_namlen." >&4
 180         val="$define"
 181  else
 182 EOPATCH
 183     }
 184 }
 185
 186 # There was a bug in makedepend.SH which was fixed in version 96a8704c.
 187 # Symptom was './makedepend: 1: Syntax error: Unterminated quoted string'
 188 # Remove this if you're actually bisecting a problem related to makedepend.SH
 189 system 'git show blead:makedepend.SH > makedepend.SH' and die;
 190
 191 my @paths = qw(/usr/local/lib64 /lib64 /usr/lib64);
 192
 193 # if Encode is not needed for the test, you can speed up the bisect by
 194 # excluding it from the runs with -Dnoextensions=Encode
 195 # ccache is an easy win. Remove it if it causes problems.
 196 my @ARGS = ('-des', '-Dusedevel', '-Doptimize=-g', '-Dcc=ccache gcc',
 197             '-Dld=gcc', "-Dlibpth=@paths");
 198
 199 # Commit 1cfa4ec74d4933da adds ignore_versioned_solibs to Configure, and sets it
 200 # to true in hints/linux.sh
 201 # On dromedary, from that point on, Configure (by default) fails to find any
 202 # libraries, because it scans /usr/local/lib /lib /usr/lib, which only contain
 203 # versioned libraries. Without -lm, the build fails.
 204 # Telling /usr/local/lib64 /lib64 /usr/lib64 works from that commit onwards,
 205 # until commit faae14e6e968e1c0 adds it to the hints.
 206 # However, prior to 1cfa4ec74d4933da telling Configure the truth doesn't work,
 207 # because it will spot versioned libraries, pass them to the compiler, and then
 208 # bail out pretty early on. Configure won't let us override libswanted, but it
 209 # will let us override the entire libs list.
 210
 211 unless (extract_from_file('Configure', 'ignore_versioned_solibs')) {
 212     # Before 1cfa4ec74d4933da, so force the libs list.
 213
 214     my @libs;
 215     # This is the current libswanted list from Configure, less the libs removed
 216     # by current hints/linux.sh
 217     foreach my $lib (qw(sfio socket inet nsl nm ndbm gdbm dbm db malloc dl dld
 218                         ld sun m crypt sec util c cposix posix ucb BSD)) {
 219         foreach my $dir (@paths) {
 220             next unless -f "$dir/lib$lib.so";
 221             push @libs, "-l$lib";
 222             last;
 223         }
 224     }
 225     push @ARGS, "-Dlibs=@libs";
 226 }
 227
 228 # This seems to be necessary to avoid makedepend becoming confused, and hanging
 229 # on stdin. Seems that the code after make shlist || ...here... is never run.
 230 push @ARGS, q{-Dtrnl='\n'}
 231     if $major < 4;
 232
 233 push @ARGS, '-Uusenm'
 234     if $major < 2;
 235
 236 my (@missing, @created_dirs);
 237
 238 if ($force_manifest) {
 239     open my $fh, '<', 'MANIFEST'
 240         or die "Could not open MANIFEST: $!";
 241     while (<$fh>) {
 242         next unless /^(\S+)/;
 243         push @missing, $1
 244             unless -f $1;
 245     }
 246     close $fh or die "Can't close MANIFEST: $!";
 247
 248     foreach my $pathname (@missing) {
 249         my @parts = split '/', $pathname;
 250         my $leaf = pop @parts;
 251         my $path = '.';
 252         while (@parts) {
 253             $path .= '/' . shift @parts;
 254             next if -d $path;
 255             mkdir $path, 0700 or die "Can't create $path: $!";
 256             unshift @created_dirs, $path;
 257         }
 258         open $fh, '>', $pathname or die "Can't open $pathname: $!";
 259         close $fh or die "Can't close $pathname: $!";
 260         chmod 0, $pathname or die "Can't chmod 0 $pathname: $!";
 261     }
 262 }
 263
 264 # </dev/null because it seems that some earlier versions of Configure can
 265 # call commands in a way that now has them reading from stdin (and hanging)
 266 my $pid = fork;
 267 die "Can't fork: $!" unless defined $pid;
 268 if (!$pid) {
 269     # Before dfe9444ca7881e71, Configure would refuse to run if stdin was not a
 270     # tty. With that commit, the tty requirement was dropped for -de and -dE
 271     if($major > 4) {
 272         open STDIN, '<', '/dev/null';
 273     } elsif (!$force_manifest) {
 274         # If a file in MANIFEST is missing, Configure asks if you want to
 275         # continue (the default being 'n'). With stdin closed or /dev/null,
 276         # it exit immediately and the check for config.sh below will skip.
 277         # To avoid a hang, we need to check MANIFEST for ourselves, and skip
 278         # if anything is missing.
 279         open my $fh, '<', 'MANIFEST';
 280         skip("Could not open MANIFEST: $!")
 281             unless $fh;
 282         while (<$fh>) {
 283             next unless /^(\S+)/;
 284             skip("$1 from MANIFEST doesn't exist")
 285                 unless -f $1;
 286         }
 287         close $fh or die "Can't close MANIFEST: $!";
 288     }
 289     exec './Configure', @ARGS;
 290     die "Failed to start Configure: $!";
 291 }
 292 waitpid $pid, 0
 293     or die "wait for Configure, pid $pid failed: $!";
 294
 295 # Skip if something went wrong with Configure
 296 skip('no config.sh') unless -f 'config.sh';
 297
 298 # This is probably way too paranoid:
 299 if (@missing) {
 300     my @errors;
 301     foreach my $file (@missing) {
 302         my (undef, undef, $mode, undef, undef, undef, undef, $size)
 303             = stat $file;
 304         if (!defined $mode) {
 305             push @errors, "Added file $file has been deleted by Configure";
 306             next;
 307         }
 308         if ($mode != 0) {
 309             push @errors,
 310                 sprintf 'Added file %s had mode changed by Configure to %03o',
 311                     $file, $mode;
 312         }
 313         if ($size != 0) {
 314             push @errors,
 315                 "Added file $file had sized changed by Configure to $size";
 316         }
 317         unlink $file or die "Can't unlink $file: $!";
 318     }
 319     foreach my $dir (@created_dirs) {
 320         rmdir $dir or die "Can't rmdir $dir: $!";
 321     }
 322     skip("@errors")
 323         if @errors;
 324 }
 325
 326 # Correct makefile for newer GNU gcc
 327 # Only really needed if you comment out the use of blead's makedepend.SH
 328 {
 329     local $^I = "";
 330     local @ARGV = qw(makefile x2p/makefile);
 331     while (<>) {
 332         print unless /<(?:built-in|command|stdin)/;
 333     }
 334 }
 335
 336 if ($major == 2 && extract_from_file('perl.c', qr/^     fclose\(e_fp\);$/)) {
 337     # need to patch perl.c to avoid calling fclose() twice on e_fp when using -e
 338     # This diff is part of commit ab821d7fdc14a438. The second close was
 339     # introduced with perl-5.002, commit a5f75d667838e8e7
 340     # Might want a6c477ed8d4864e6 too, for the corresponding change to pp_ctl.c
 341     # (likely without this, eval will have "fun")
 342     apply_patch(<<'EOPATCH');
 343 diff --git a/perl.c b/perl.c
 344 index 03c4d48..3c814a2 100644
 345 --- a/perl.c
 346 +++ b/perl.c
 347 @@ -252,6 +252,7 @@ setuid perl scripts securely.\n");
 348  #ifndef VMS  /* VMS doesn't have environ array */
 349      origenviron = environ;
 350  #endif
 351 +    e_tmpname = Nullch;
 352
 353      if (do_undump) {
 354
 355 @@ -405,6 +406,7 @@ setuid perl scripts securely.\n");
 356      if (e_fp) {
 357         if (Fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
 358             croak("Can't write to temp file for -e: %s", Strerror(errno));
 359 +       e_fp = Nullfp;
 360         argc++,argv--;
 361         scriptname = e_tmpname;
 362      }
 363 @@ -470,10 +472,10 @@ setuid perl scripts securely.\n");
 364      curcop->cop_line = 0;
 365      curstash = defstash;
 366      preprocess = FALSE;
 367 -    if (e_fp) {
 368 -       fclose(e_fp);
 369 -       e_fp = Nullfp;
 370 +    if (e_tmpname) {
 371         (void)UNLINK(e_tmpname);
 372 +       Safefree(e_tmpname);
 373 +       e_tmpname = Nullch;
 374      }
 375
 376      /* now that script is parsed, we can modify record separator */
 377 @@ -1369,7 +1371,7 @@ SV *sv;
 378         scriptname = xfound;
 379      }
 380
 381 -    origfilename = savepv(e_fp ? "-e" : scriptname);
 382 +    origfilename = savepv(e_tmpname ? "-e" : scriptname);
 383      curcop->cop_filegv = gv_fetchfile(origfilename);
 384      if (strEQ(origfilename,"-"))
 385         scriptname = "";
 386
 387 EOPATCH
 388 }
 389
 390 # Parallel build for miniperl is safe
 391 system "make $j miniperl";
 392
 393 if ($target ne 'miniperl') {
 394     # Nearly all parallel build issues fixed by 5.10.0. Untrustworthy before that.
 395     $j = '' unless $major > 10;
 396
 397     if ($target eq 'test_prep') {
 398         if ($major < 8) {
 399             # test-prep was added in 5.004_01, 3e3baf6d63945cb6.
 400             # renamed to test_prep in 2001 in 5fe84fd29acaf55c.
 401             # earlier than that, just make test. It will be fast enough.
 402             $target = extract_from_file('Makefile.SH', qr/^(test[-_]prep):/,
 403                                         'test');
 404         }
 405     }
 406
 407     system "make $j $target";
 408 }
 409
 410 my $missing_target = $expected =~ /perl$/ ? !-x $expected : !-r $expected;
 411
 412 if ($test_build) {
 413     report_and_exit($missing_target, 'could build', 'could not build', $target);
 414 } elsif ($missing_target) {
 415     skip("could not build $target");
 416 }
 417
 418 # This is what we came here to run:
 419 my $ret = system @ARGV;
 420
 421 report_and_exit($ret, 'zero exit from', 'non-zero exit from', "@ARGV");
 422
 423 # Local variables:
 424 # cperl-indent-level: 4
 425 # indent-tabs-mode: nil
 426 # End:
 427 #
 428 # ex: set ts=8 sts=4 sw=4 et: