Porting/bisect.pl

   1 #!/usr/bin/perl -w
   2 use strict;
   3
   4 =for comment
   5
   6 Documentation for this is in bisect-runner.pl
   7
   8 =cut
   9
  10 # The default, auto_abbrev will treat -e as an abbreviation of --end
  11 # Which isn't what we want.
  12 use Getopt::Long qw(:config pass_through no_auto_abbrev);
  13
  14 my ($start, $end, $validate, $usage, $bad, $jobs, $make, $gold);
  15 $bad = !GetOptions('start=s' => \$start, 'end=s' => \$end,
  16                    'jobs|j=i' => \$jobs, 'make=s' => \$make, 'gold=s' => \$gold,
  17                    validate => \$validate, 'usage|help|?' => \$usage);
  18 unshift @ARGV, '--help' if $bad || $usage;
  19 unshift @ARGV, '--validate' if $validate;
  20
  21 my $runner = $0;
  22 $runner =~ s/bisect\.pl/bisect-runner.pl/;
  23
  24 die "Can't find bisect runner $runner" unless -f $runner;
  25
  26 system $^X, $runner, '--check-args', '--check-shebang', @ARGV and exit 255;
  27 exit 255 if $bad;
  28 exit 0 if $usage;
  29
  30 my $start_time = time;
  31
  32 if (!defined $jobs &&
  33     !($^O eq 'hpux' && system((defined $make ? $make : 'make')
  34                               . ' --version >/dev/null 2>&1'))) {
  35     # Try to default to (ab)use all the CPUs:
  36     my $cpus;
  37     if (open my $fh, '<', '/proc/cpuinfo') {
  38         while (<$fh>) {
  39             ++$cpus if /^processor\s+:\s+\d+$/;
  40         }
  41     } elsif (-x '/sbin/sysctl') {
  42         $cpus =  $1 if `/sbin/sysctl hw.ncpu` =~ /^hw\.ncpu: (\d+)$/;
  43     } elsif (-x '/usr/bin/getconf') {
  44         $cpus = $1 if `/usr/bin/getconf _NPROCESSORS_ONLN` =~ /^(\d+)$/;
  45     }
  46     $jobs = defined $cpus ? $cpus + 1 : 2;
  47 }
  48
  49 unshift @ARGV, '--jobs', $jobs if defined $jobs;
  50 unshift @ARGV, '--make', $make if defined $make;
  51
  52 # We try these in this order for the start revision if none is specified.
  53 my @stable = map {chomp $_; $_} grep {/v5\.[0-9]+[02468]\.0$/} `git tag -l`;
  54 die "git tag -l didn't seem to return any tags for stable releases"
  55     unless @stable;
  56 unshift @stable, qw(perl-5.005 perl-5.6.0 perl-5.8.0);
  57
  58 {
  59     my ($dev_C, $ino_C) = stat 'Configure';
  60     my ($dev_c, $ino_c) = stat 'configure';
  61     if (defined $dev_C && defined $dev_c
  62         && $dev_C == $dev_c && $ino_C == $ino_c) {
  63         print "You seem to be on a case-insensitive file system.\n\n";
  64     } else {
  65         unshift @stable, qw(perl-5.002 perl-5.003 perl-5.004)
  66     }
  67 }
  68
  69 unshift @ARGV, '--gold', defined $gold ? $gold : $stable[-1];
  70
  71 if (!defined $end) {
  72     # If we have a branch blead, use that as the end
  73     $end = `git rev-parse --verify --quiet blead`;
  74     die unless defined $end;
  75     if (!length $end) {
  76         # Else use whichever is newer - HEAD, or the most recent stable tag.
  77         if (`git rev-list -n1 HEAD ^$stable[-1]` eq "") {
  78             $end = pop @stable;
  79         } else {
  80             $end = 'HEAD';
  81         }
  82     }
  83 }
  84
  85 # Canonicalising branches to revisions before moving the checkout permits one
  86 # to use revisions such as 'HEAD' for --start or --end
  87 foreach ($start, $end) {
  88     next unless $_;
  89     $_ = `git rev-parse $_`;
  90     die unless defined $_;
  91     chomp;
  92 }
  93
  94 {
  95     my $modified = my @modified = `git ls-files --modified --deleted --others`;
  96
  97     my ($dev0, $ino0) = stat $0;
  98     die "Can't stat $0: $!" unless defined $ino0;
  99     my ($dev1, $ino1) = stat 'Porting/bisect.pl';
 100
 101     my $inplace = defined $dev1 && $dev0 == $dev1 && $ino0 == $ino1;
 102
 103     if ($modified) {
 104         my $final = $inplace
 105             ? "Can't run a bisect using a dirty directory containing $runner"
 106             : "You can use 'git clean -Xdf' to cleanup the ignored files";
 107
 108         die "This checkout is not clean, found file(s):\n",
 109             join("\t","",@modified),
 110                 "$modified modified, untracked, or other file(s)\n",
 111                 "These files may not show in git status as they may be ignored.\n",
 112                 "$final.\n";
 113     }
 114
 115     if ($inplace) {
 116         # We assume that it's safe to copy the runner to the temporary
 117         # directory and run it from there, because a shared /tmp should be +t
 118         # and hence others are not be able to delete or rename our file.
 119         require File::Temp;
 120         my ($to, $toname) = File::Temp::tempfile();
 121         die "Can't create tempfile"
 122             unless $to;
 123         open my $from, '<', $runner
 124             or die "Can't open '$runner': $!";
 125         local $/;
 126         print {$to} <$from>
 127             or die "Can't copy from '$runner' to '$toname': $!";
 128         close $from
 129             or die "Can't close '$runner': $!";
 130         close $to
 131             or die "Can't close '$toname': $!";
 132         chmod 0500, $toname
 133             or die "Can't chmod 0500, '$toname': $!";
 134         $runner = $toname;
 135         system $^X, $runner, '--check-args', @ARGV
 136             and die "Can't run inplace for some reason. :-(";
 137     }
 138 }
 139
 140 sub validate {
 141     my $commit = shift;
 142     if (defined $start && `git rev-list -n1 $commit ^$start^` eq "") {
 143         print "Skipping $commit, as it is earlier than $start\n";
 144         return;
 145     }
 146     if (defined $end && `git rev-list -n1 $end ^$commit^` eq "") {
 147         print "Skipping $commit, as it is more recent than $end\n";
 148         return;
 149     }
 150     print "Testing $commit...\n";
 151     system "git checkout $commit </dev/null" and die;
 152     my $ret = system $^X, $runner, '--no-clean', @ARGV;
 153     die "Runner returned $ret, not 0 for revision $commit" if $ret;
 154     system 'git clean -dxf </dev/null' and die;
 155     system 'git reset --hard HEAD </dev/null' and die;
 156     return $commit;
 157 }
 158
 159 if ($validate) {
 160     require Text::Wrap;
 161     my @built = map {validate $_} 'blead', reverse @stable;
 162     if (@built) {
 163         print Text::Wrap::wrap("", "", "Successfully validated @built\n");
 164         exit 0;
 165     }
 166     print "Did not validate anything\n";
 167     exit 1;
 168 }
 169
 170 my $git_version = `git --version`;
 171 if (defined $git_version
 172     && $git_version =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) {
 173     $git_version = eval "v$1";
 174 } else {
 175     $git_version = v0.0.0;
 176 }
 177
 178 if ($git_version ge v1.6.6) {
 179     system "git bisect reset HEAD" and die;
 180 } else {
 181     system "git bisect reset" and die;
 182 }
 183
 184 # Sanity check the first and last revisions:
 185 system "git checkout $end" and die;
 186 my $ret = system $^X, $runner, @ARGV;
 187 die "Runner returned $ret for end revision" unless $ret;
 188 die "Runner returned $ret for end revision, which is a skip"
 189     if $ret == 125 * 256;
 190
 191 if (defined $start) {
 192     system "git checkout $start" and die;
 193     my $ret = system $^X, $runner, @ARGV;
 194     die "Runner returned $ret, not 0 for start revision" if $ret;
 195 } else {
 196     # Try to find the earliest version for which the test works
 197     my @tried;
 198     foreach my $try (@stable) {
 199         if (`git rev-list -n1 $end ^$try^` eq "") {
 200             print "Skipping $try, as it is more recent than end commit "
 201                 . (substr $end, 0, 16) . "\n";
 202             # As @stable is supposed to be in age order, arguably we should
 203             # last; here.
 204             next;
 205         }
 206         system "git checkout $try" and die;
 207         my $ret = system $^X, $runner, @ARGV;
 208         if (!$ret) {
 209             $start = $try;
 210             last;
 211         }
 212         push @tried, $try;
 213     }
 214     die "Can't find a suitable start revision to default to.\nTried @tried"
 215         unless defined $start;
 216 }
 217
 218 system "git bisect start" and die;
 219 system "git bisect good $start" and die;
 220 system "git bisect bad $end" and die;
 221
 222 # And now get git bisect to do the hard work:
 223 system 'git', 'bisect', 'run', $^X, $runner, @ARGV and die;
 224
 225 END {
 226     my $end_time = time;
 227
 228     printf "That took %d seconds\n", $end_time - $start_time
 229         if defined $start_time;
 230 }
 231
 232 =for comment
 233
 234 Documentation for this is in bisect-runner.pl
 235
 236 =cut
 237
 238 # Local variables:
 239 # cperl-indent-level: 4
 240 # indent-tabs-mode: nil
 241 # End:
 242 #
 243 # ex: set ts=8 sts=4 sw=4 et: