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