File: bisect.pl

package info (click to toggle)
perl 5.24.1-3+deb9u5
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 103,716 kB
  • sloc: perl: 559,611; ansic: 293,886; sh: 67,316; pascal: 7,632; cpp: 3,895; makefile: 2,436; xml: 2,410; yacc: 989; sed: 6; lisp: 1
file content (282 lines) | stat: -rwxr-xr-x 8,879 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
#!/usr/bin/perl -w
use strict;

=for comment

Documentation for this is in bisect-runner.pl

=cut

# The default, auto_abbrev will treat -e as an abbreviation of --end
# Which isn't what we want.
use Getopt::Long qw(:config pass_through no_auto_abbrev);
use File::Spec;
use File::Path qw(mkpath);

my ($start, $end, $validate, $usage, $bad, $jobs, $make, $gold,
    $module, $with_module);

my $need_cpan_config;
my $cpan_config_dir;

$bad = !GetOptions('start=s' => \$start, 'end=s' => \$end,
                   'jobs|j=i' => \$jobs, 'make=s' => \$make, 'gold=s' => \$gold,
                   validate => \$validate, 'usage|help|?' => \$usage,
                   'module=s' => \$module, 'with-module=s' => \$with_module,
                   'cpan-config-dir=s' => \$cpan_config_dir);
unshift @ARGV, '--help' if $bad || $usage;
unshift @ARGV, '--validate' if $validate;

if ($module || $with_module) {
  unshift @ARGV, '--module', $module if defined $module;
  unshift @ARGV, '--with-module', $with_module if defined $with_module;

  if ($cpan_config_dir) {
    my $c = File::Spec->catfile($cpan_config_dir, 'CPAN', 'MyConfig.pm');
    die "--cpan-config-dir: $c does not exist\n" unless -e $c;

    unshift @ARGV, '--cpan-config-dir', $cpan_config_dir;
  } else {
    $need_cpan_config = 1;
  }
}

my $runner = $0;
$runner =~ s/bisect\.pl/bisect-runner.pl/;

die "Can't find bisect runner $runner" unless -f $runner;

system $^X, $runner, '--check-args', '--check-shebang', @ARGV and exit 255;
exit 255 if $bad;
exit 0 if $usage;

my $start_time = time;

if (!defined $jobs &&
    !($^O eq 'hpux' && system((defined $make ? $make : 'make')
                              . ' --version >/dev/null 2>&1'))) {
    # Try to default to (ab)use all the CPUs:
    my $cpus;
    if (open my $fh, '<', '/proc/cpuinfo') {
        while (<$fh>) {
            ++$cpus if /^processor\s+:\s+\d+$/;
        }
    } elsif (-x '/sbin/sysctl') {
        $cpus =  $1 if `/sbin/sysctl hw.ncpu` =~ /^hw\.ncpu: (\d+)$/;
    } elsif (-x '/usr/bin/getconf') {
        $cpus = $1 if `/usr/bin/getconf _NPROCESSORS_ONLN` =~ /^(\d+)$/;
    }
    $jobs = defined $cpus ? $cpus + 1 : 2;
}

unshift @ARGV, '--jobs', $jobs if defined $jobs;
unshift @ARGV, '--make', $make if defined $make;

if ($need_cpan_config) {
  # Make sure we have a CPAN::MyConfig so if we start at an old
  # revision CPAN doesn't ask for user input to configure itself

  my $cdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
  my $cfile = File::Spec->catfile($cdir, "MyConfig.pm");

  unless (-e $cfile) {
    printf <<EOF;
I could not find a CPAN::MyConfig. We need to create one now so that
you can bisect with --module or --with-module. I'll boot up the CPAN
shell for you. Feel free to use defaults or change things as needed.
We recommend using 'manual' over 'local::lib' if it asks.

Type 'quit' when finished.

EOF
    system("$^X -MCPAN -e shell");
  }
}

# We try these in this order for the start revision if none is specified.
my @stable = map {chomp $_; $_} grep {/v5\.[0-9]+[02468]\.0$/} `git tag -l`;
die "git tag -l didn't seem to return any tags for stable releases"
    unless @stable;
unshift @stable, qw(perl-5.005 perl-5.6.0 perl-5.8.0);

{
    my ($dev_C, $ino_C) = stat 'Configure';
    my ($dev_c, $ino_c) = stat 'configure';
    if (defined $dev_C && defined $dev_c
        && $dev_C == $dev_c && $ino_C == $ino_c) {
        print "You seem to be on a case-insensitive file system.\n\n";
    } else {
        unshift @stable, qw(perl-5.002 perl-5.003 perl-5.004)
    }
}

unshift @ARGV, '--gold', defined $gold ? $gold : $stable[-1];

if (!defined $end) {
    # If we have a branch blead, use that as the end
    $end = `git rev-parse --verify --quiet blead`;
    die unless defined $end;
    if (!length $end) {
        # Else use whichever is newer - HEAD, or the most recent stable tag.
        if (`git rev-list -n1 HEAD ^$stable[-1]` eq "") {
            $end = pop @stable;
        } else {
            $end = 'HEAD';
        }
    }
}

# Canonicalising branches to revisions before moving the checkout permits one
# to use revisions such as 'HEAD' for --start or --end
foreach ($start, $end) {
    next unless $_;
    $_ = `git rev-parse $_`;
    die unless defined $_;
    chomp;
}

{
    my $modified = my @modified = `git ls-files --modified --deleted --others`;

    my ($dev0, $ino0) = stat $0;
    die "Can't stat $0: $!" unless defined $ino0;
    my ($dev1, $ino1) = stat 'Porting/bisect.pl';

    my $inplace = defined $dev1 && $dev0 == $dev1 && $ino0 == $ino1;

    if ($modified) {
        my $final = $inplace
            ? "Can't run a bisect using a dirty directory containing $runner"
            : "You can use 'git clean -Xdf' to cleanup the ignored files";

        die "This checkout is not clean, found file(s):\n",
            join("\t","",@modified),
                "$modified modified, untracked, or other file(s)\n",
                "These files may not show in git status as they may be ignored.\n",
                "$final.\n";
    }

    if ($inplace) {
        # We assume that it's safe to copy the runner to the temporary
        # directory and run it from there, because a shared /tmp should be +t
        # and hence others are not be able to delete or rename our file.
        require File::Temp;
        my ($to, $toname) = File::Temp::tempfile();
        die "Can't create tempfile"
            unless $to;
        open my $from, '<', $runner
            or die "Can't open '$runner': $!";
        local $/;
        print {$to} <$from>
            or die "Can't copy from '$runner' to '$toname': $!";
        close $from
            or die "Can't close '$runner': $!";
        close $to
            or die "Can't close '$toname': $!";
        chmod 0500, $toname
            or die "Can't chmod 0500, '$toname': $!";
        $runner = $toname;
        system $^X, $runner, '--check-args', @ARGV
            and die "Can't run inplace for some reason. :-(";
    }
}

sub validate {
    my $commit = shift;
    if (defined $start && `git rev-list -n1 $commit ^$start^` eq "") {
        print "Skipping $commit, as it is earlier than $start\n";
        return;
    }
    if (defined $end && `git rev-list -n1 $end ^$commit^` eq "") {
        print "Skipping $commit, as it is more recent than $end\n";
        return;
    }
    print "Testing $commit...\n";
    system "git checkout $commit </dev/null" and die;
    my $ret = system $^X, $runner, '--no-clean', @ARGV;
    die "Runner returned $ret, not 0 for revision $commit" if $ret;
    system 'git clean -dxf </dev/null' and die;
    system 'git reset --hard HEAD </dev/null' and die;
    return $commit;
}

if ($validate) {
    require Text::Wrap;
    my @built = map {validate $_} 'blead', reverse @stable;
    if (@built) {
        print Text::Wrap::wrap("", "", "Successfully validated @built\n");
        exit 0;
    }
    print "Did not validate anything\n";
    exit 1;
}

my $git_version = `git --version`;
if (defined $git_version
    && $git_version =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) {
    $git_version = eval "v$1";
} else {
    $git_version = v0.0.0;
}

if ($git_version ge v1.6.6) {
    system "git bisect reset HEAD" and die;
} else {
    system "git bisect reset" and die;
}

# Sanity check the first and last revisions:
system "git checkout $end" and die;
my $ret = system $^X, $runner, @ARGV;
die "Runner returned $ret for end revision" unless $ret;
die "Runner returned $ret for end revision, which is a skip"
    if $ret == 125 * 256;

if (defined $start) {
    system "git checkout $start" and die;
    my $ret = system $^X, $runner, @ARGV;
    die "Runner returned $ret, not 0 for start revision" if $ret;
} else {
    # Try to find the earliest version for which the test works
    my @tried;
    foreach my $try (@stable) {
        if (`git rev-list -n1 $end ^$try^` eq "") {
            print "Skipping $try, as it is more recent than end commit "
                . (substr $end, 0, 16) . "\n";
            # As @stable is supposed to be in age order, arguably we should
            # last; here.
            next;
        }
        system "git checkout $try" and die;
        my $ret = system $^X, $runner, @ARGV;
        if (!$ret) {
            $start = $try;
            last;
        }
        push @tried, $try;
    }
    die "Can't find a suitable start revision to default to.\nTried @tried"
        unless defined $start;
}

system "git bisect start" and die;
system "git bisect good $start" and die;
system "git bisect bad $end" and die;

# And now get git bisect to do the hard work:
system 'git', 'bisect', 'run', $^X, $runner, @ARGV and die;

END {
    my $end_time = time;

    printf "That took %d seconds.\n", $end_time - $start_time
        if defined $start_time;
}

=for comment

Documentation for this is in bisect-runner.pl

=cut

# ex: set ts=8 sts=4 sw=4 et: