This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
If there is no 'blead' branch, bisect.pl now uses a suitable alternative.
[perl5.git] / 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 {
31     my ($dev0, $ino0) = stat $0;
32     die "Can't stat $0: $!" unless defined $ino0;
33     my ($dev1, $ino1) = stat 'Porting/bisect.pl';
34     die "Can't run a bisect using the directory containing $runner"
35       if defined $dev1 && $dev0 == $dev1 && $ino0 == $ino1;
36 }
37
38 my $start_time = time;
39
40 if (!defined $jobs &&
41     !($^O eq 'hpux' && system((defined $make ? $make : 'make')
42                               . ' --version >/dev/null 2>&1'))) {
43     # Try to default to (ab)use all the CPUs:
44     my $cpus;
45     if (open my $fh, '<', '/proc/cpuinfo') {
46         while (<$fh>) {
47             ++$cpus if /^processor\s+:\s+\d+$/;
48         }
49     } elsif (-x '/sbin/sysctl') {
50         $cpus =  $1 if `/sbin/sysctl hw.ncpu` =~ /^hw\.ncpu: (\d+)$/;
51     } elsif (-x '/usr/bin/getconf') {
52         $cpus = $1 if `/usr/bin/getconf _NPROCESSORS_ONLN` =~ /^(\d+)$/;
53     }
54     $jobs = defined $cpus ? $cpus + 1 : 2;
55 }
56
57 unshift @ARGV, '--jobs', $jobs if defined $jobs;
58 unshift @ARGV, '--make', $make if defined $make;
59
60 # We try these in this order for the start revision if none is specified.
61 my @stable = map {chomp $_; $_} grep {/v5\.[0-9]+[02468]\.0$/} `git tag -l`;
62 die "git tag -l didn't seem to return any tags for stable releases"
63     unless @stable;
64 unshift @stable, qw(perl-5.005 perl-5.6.0 perl-5.8.0);
65
66 {
67     my ($dev_C, $ino_C) = stat 'Configure';
68     my ($dev_c, $ino_c) = stat 'configure';
69     if (defined $dev_C && defined $dev_c
70         && $dev_C == $dev_c && $ino_C == $ino_c) {
71         print "You seem to be on a case-insensitive file system.\n\n";
72     } else {
73         unshift @stable, qw(perl-5.002 perl-5.003 perl-5.004)
74     }
75 }
76
77 unshift @ARGV, '--gold', defined $gold ? $gold : $stable[-1];
78
79 if (!defined $end) {
80     # If we have a branch blead, use that as the end
81     $end = `git rev-parse --verify --quiet blead`;
82     die unless defined $end;
83     if (!length $end) {
84         # Else use whichever is newer - HEAD, or the most recent stable tag.
85         if (`git rev-list -n1 HEAD ^$stable[-1]` eq "") {
86             $end = pop @stable;
87         } else {
88             $end = 'HEAD';
89         }
90     }
91 }
92
93 # Canonicalising branches to revisions before moving the checkout permits one
94 # to use revisions such as 'HEAD' for --start or --end
95 foreach ($start, $end) {
96     next unless $_;
97     $_ = `git rev-parse $_`;
98     die unless defined $_;
99     chomp;
100 }
101
102 my $modified = my @modified = `git ls-files --modified --deleted --others`;
103
104 die "This checkout is not clean, found file(s):\n",
105     join("\t","",@modified),
106     "$modified modified, untracked, or other file(s)\n",
107     "These files may not show in git status as they may be ignored.\n",
108     "You can use 'git clean -Xdf' to cleanup the ignored files.\n"
109     if $modified;
110
111 sub validate {
112     my $commit = shift;
113     if (defined $start && `git rev-list -n1 $commit ^$start^` eq "") {
114         print "Skipping $commit, as it is earlier than $start\n";
115         return;
116     }
117     if (defined $end && `git rev-list -n1 $end ^$commit^` eq "") {
118         print "Skipping $commit, as it is more recent than $end\n";
119         return;
120     }
121     print "Testing $commit...\n";
122     system "git checkout $commit </dev/null" and die;
123     my $ret = system $^X, $runner, '--no-clean', @ARGV;
124     die "Runner returned $ret, not 0 for revision $commit" if $ret;
125     system 'git clean -dxf </dev/null' and die;
126     system 'git reset --hard HEAD </dev/null' and die;
127     return $commit;
128 }
129
130 if ($validate) {
131     require Text::Wrap;
132     my @built = map {validate $_} 'blead', reverse @stable;
133     if (@built) {
134         print Text::Wrap::wrap("", "", "Successfully validated @built\n");
135         exit 0;
136     }
137     print "Did not validate anything\n";
138     exit 1;
139 }
140
141 my $git_version = `git --version`;
142 if (defined $git_version
143     && $git_version =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) {
144     $git_version = eval "v$1";
145 } else {
146     $git_version = v0.0.0;
147 }
148
149 if ($git_version ge v1.6.6) {
150     system "git bisect reset HEAD" and die;
151 } else {
152     system "git bisect reset" and die;
153 }
154
155 # Sanity check the first and last revisions:
156 system "git checkout $end" and die;
157 my $ret = system $^X, $runner, @ARGV;
158 die "Runner returned $ret for end revision" unless $ret;
159 die "Runner returned $ret for end revision, which is a skip"
160     if $ret == 125 * 256;
161
162 if (defined $start) {
163     system "git checkout $start" and die;
164     my $ret = system $^X, $runner, @ARGV;
165     die "Runner returned $ret, not 0 for start revision" if $ret;
166 } else {
167     # Try to find the earliest version for which the test works
168     my @tried;
169     foreach my $try (@stable) {
170         if (`git rev-list -n1 $end ^$try^` eq "") {
171             print "Skipping $try, as it is more recent than end commit "
172                 . (substr $end, 0, 16) . "\n";
173             # As @stable is supposed to be in age order, arguably we should
174             # last; here.
175             next;
176         }
177         system "git checkout $try" and die;
178         my $ret = system $^X, $runner, @ARGV;
179         if (!$ret) {
180             $start = $try;
181             last;
182         }
183         push @tried, $try;
184     }
185     die "Can't find a suitable start revision to default to.\nTried @tried"
186         unless defined $start;
187 }
188
189 system "git bisect start" and die;
190 system "git bisect good $start" and die;
191 system "git bisect bad $end" and die;
192
193 # And now get git bisect to do the hard work:
194 system 'git', 'bisect', 'run', $^X, $runner, @ARGV and die;
195
196 END {
197     my $end_time = time;
198
199     printf "That took %d seconds\n", $end_time - $start_time
200         if defined $start_time;
201 }
202
203 =for comment
204
205 Documentation for this is in bisect-runner.pl
206
207 =cut
208
209 # Local variables:
210 # cperl-indent-level: 4
211 # indent-tabs-mode: nil
212 # End:
213 #
214 # ex: set ts=8 sts=4 sw=4 et: