#!/usr/bin/perl -w -- -*- mode: cperl -*-
our
$Id
=
q$Id: binsearchaperl 270 2007-11-11 07:47:27Z k $
;
our
$APC
;
our
%Opt
;
GetOptions(
\
%Opt
,
"apcdir=s"
,
"bounds=s"
,
"branch=s"
,
"build!"
,
"cachefilter=s"
,
"config=s"
,
"die-on-error!"
,
"exact-bounds=s"
,
"h|help!"
,
"maxbuild:i"
,
"prefix=s"
,
"prep:s"
,
"prog:s"
,
"show-cache!"
,
"switches:s"
,
"verbose!"
,
"version"
,
) or
die
Usage();
sub
Usage {
qq{USAGE: $0 OPTIONS
--config=... # Configure options except --prefix; default none;
# if given, it is passed to buildaperl, otherwise
# buildaperl has its own default value
--apcdir=... # local path to the All Perl Changes archive;
# defaults to "APC" in the current directory
--bounds NNNN-NNNN # lower-upper bounds (script is tolerant and
# chooses alternative bounds if these don't exist)
--branch # Defaults to "perl" (//depot/perl)
--build # boolean option: if false, we do not build any perl
--cachefilter program # program that returns on shell level true or
# false; perls returning false are ignored
--die-on-error # do not try to continue if a perl can't be built
--exact-bounds NNNN-NNNN # as --bounds, but build the bounds if needed
--help # This help page
--maxbuild N # How many perls to build; then exit with 0 status
--prefix=... # prefix of the inst directory;
# defaults to "installed-perls" in current dir
--prep program # an optional perl script to run before the
# the comparison; can be used to e.g. install
# modules from CPAN
--prog program # the perl script to use to compare two perls
--show-cache # list all found perls sorted by patchlevel and exit
--switches switches
--verbose
--version # show version and exit
Example:
binsearchaperl --verbose --bounds 14354-17507 --switches=-T --prog tests/chip_taint.pl --build
}
;
}
if
(
$Opt
{h}) {
print
Usage;
exit
;
}
if
(
$Opt
{version}) {
print
"$Id\n"
;
exit
;
}
our
%NOSUCCESS
;
sub
allperls ($$);
sub
buildnext ($);
sub
findperl ($$);
sub
findmiddleperl ($$);
sub
findmiddlepatch ($$);
$Opt
{prefix} ||=
"installed-perls"
;
$Opt
{branch} ||=
"perl"
;
my
$legal_branch
=
qr[
^
(?:
perl
|
maint-(\d+\.\d+)
(?:/perl-5.6.2)?
)
$
]
x;
unless
(
$Opt
{branch} =~
$legal_branch
) {
die
"--branch option [$Opt{branch} does not match $legal_branch]; cannot continue"
;
}
my
$exact
= 0;
if
(
$Opt
{
"exact-bounds"
}) {
$Opt
{bounds} =
$Opt
{
"exact-bounds"
};
$exact
= 1;
}
$Opt
{bounds} ||=
"1-9999999"
;
die
"Illegal bounds argument, must match /^\\d+-\\d+\$/"
unless
$Opt
{bounds} =~ /^(\d+)-(\d+)$/;
my
(
$lower
,
$upper
) = ($1,$2);
die
"bounds argument illegal: lower[$lower] upper[$upper]"
unless
$lower
<=
$upper
;
if
(
$Opt
{
"show-cache"
}) {
print
map
{
"$_->[1]\n"
} allperls(
$lower
,
$upper
);
exit
;
}
$Opt
{apcdir} ||=
"APC"
;
die
"Could not find directory $Opt{apcdir}"
unless
-d
$Opt
{apcdir};
die
"Neither --prog nor --show-cache argument"
unless
$Opt
{prog};
die
"Could not find file '$Opt{prog}'"
unless
-f
$Opt
{prog};
$Opt
{switches} ||=
""
;
die
"Could not find file '$Opt{cachefilter}'"
if
$Opt
{cachefilter} && ! -f
$Opt
{cachefilter};
our
$built
= 0;
while
(
$upper
-
$lower
> 0) {
my
(
$lperl
,
$lid
) = findperl(
$lower
,
$exact
?
"="
:
"<"
);
if
(
$lid
) {
$lower
=
$lid
;
}
else
{
my
@offer
= allperls(1,999999999);
if
(
@offer
) {
warn
"Lowest perl in cache is $offer[0][1], "
.
"not suitable for lower bound $lower\n"
;
}
else
{
warn
"Could not find a suitable perl for lower bound $lower\n"
;
}
}
my
(
$uperl
,
$uid
) = findperl(
$upper
,
$exact
?
"="
:
">"
);
if
(
$uid
) {
$upper
=
$uid
;
}
else
{
my
@offer
= allperls(1,999999999);
if
(
@offer
) {
if
(
$exact
) {
warn
"Highest perl in cache is $offer[-1][1], "
.
"$upper is too large as a bounds parameter\n"
;
}
else
{
warn
"Highest perl in cache is $offer[-1][1], will take that instead\n"
;
local
$/ = $^O eq
"Win32"
?
"\\"
:
"/"
;
my
(
$n
) =
$offer
[-1][1] =~ m|$/perl-[^$/]+\@(\d+)$/bin$/perl$|;
(
$uperl
,
$upper
) = (
$offer
[-1][1],
$n
);
}
}
else
{
warn
"Could not find a suitable perl for upper bound $upper\n"
;
}
}
unless
(
$lperl
&&
$uperl
) {
warn
"Could not find a perl. Please try '--exact-bounds' to "
.
"build the bounds\n"
;
last
;
}
local
$| = 1;
if
(
my
$prep
=
$Opt
{prep}) {
for
my
$aperl
(
$lperl
,
$uperl
) {
next
unless
defined
$aperl
;
warn
"Running the prep script '$prep' for $aperl\n"
if
$Opt
{verbose};
my
$i
= 0;
while
() {
last
if
0==
system
$aperl
,
$prep
;
$i
++;
if
(
$i
<= 3) {
warn
"Warning: The '$prep' script failed run $i on $aperl; retrying\n"
;
}
else
{
die
"Could not run the '$prep' script with $aperl in three tries"
;
}
}
}
}
warn
"Running the prog '$Opt{prog}' for $lperl and $uperl\n"
if
$Opt
{verbose};
my
(
$lres
,
$lret
,
$ures
,
$uret
);
if
(
$lperl
) {
$lres
= `
$lperl
$Opt
{switches}
$Opt
{prog} 2>&1`;
$lret
= $?;
}
else
{
$lres
=
""
;
$lret
= -1;
}
if
(
$uperl
) {
$ures
= `
$uperl
$Opt
{switches}
$Opt
{prog} 2>&1`;
$uret
= $?;
}
else
{
$ures
=
""
;
$uret
= -1;
}
my
$maxl
= 34;
my
$prog
;
if
(
$Opt
{verbose}) {
open
my
$fh
,
$Opt
{prog} or
die
;
local
$/;
$prog
= <
$fh
>;
my
$ltrunk
=
length
(
$lperl
)>
$maxl
? (
"..."
.
substr
(
$lperl
,-
$maxl
)) :
$lperl
;
my
$utrunk
=
length
(
$uperl
)>
$maxl
? (
"..."
.
substr
(
$uperl
,-
$maxl
)) :
$uperl
;
print
<<END;
----Program----
$prog
----Output of $ltrunk----
$lres
----EOF (\$?='$lret')----
----Output of $utrunk----
$ures
----EOF (\$?='$uret')----
END
}
die
qq{both perls $lower and $upper produce same result and \$?; }
.
qq{cannot continue.
lperl [$lperl]
uperl [$uperl]
}
if
$lres
eq
$ures
&&
$lret
eq
$uret
;
warn
"Need a perl between $lower and $upper\n"
;
$APC
||= Perl::Repository::APC->new(
$Opt
{apcdir});
my
$between
=
$APC
->patch_range(
$Opt
{branch},
$lower
,
$upper
);
my
$between_expl
;
shift
@$between
if
$between
->[0] eq
$lower
;
pop
@$between
if
$between
->[-1] eq
$upper
;
if
(
@$between
> 3) {
$between_expl
=
sprintf
"%d candidates"
,
scalar
@$between
;
}
else
{
$between_expl
=
sprintf
"%s"
,
join
(
","
,
@$between
);
}
$0 =
"binsearchaperl: searching between $lower and $upper ($between_expl)"
;
if
(
%NOSUCCESS
) {
for
my
$k
(
keys
%NOSUCCESS
) {
delete
$NOSUCCESS
{
$k
}
if
$k
<
$lower
||
$k
>
$upper
;
}
}
if
(
%NOSUCCESS
) {
warn
sprintf
"(but %s could not successfully be used to build perl)\n"
,
join
(
", "
,
sort
{
$a
<=>
$b
}
keys
%NOSUCCESS
);
}
FINDMIDDLE: {
if
(
my
(
$middle
) = findmiddleperl(
$lower
,
$upper
)) {
my
(
$number
,
$mperl
) =
@$middle
;
warn
"Found perl in the middle: number[
$number
]
mperl[
$mperl
]\n";
if
(
my
$prep
=
$Opt
{prep}) {
warn
"Running the prep script '$prep' for $mperl\n"
if
$Opt
{verbose};
my
$i
= 0;
while
() {
last
if
0==
system
$mperl
,
$prep
;
$i
++;
if
(
$i
<= 3) {
warn
"Warning: The '$prep' script failed run $i on $mperl; retrying\n"
;
}
else
{
die
"Could not run the '$prep' script with $mperl in three tries"
;
}
}
}
warn
"Running the prog '$Opt{prog}' for $mperl\n"
if
$Opt
{verbose};
my
$mres
= `
$mperl
$Opt
{switches}
$Opt
{prog} 2>&1`;
my
$mret
= $?;
if
(
$Opt
{verbose}) {
my
$mtrunk
=
length
(
$mperl
)>
$maxl
? (
"..."
.
substr
(
$mperl
,-
$maxl
)) :
$mperl
;
print
<<END;
----Program----
$prog
----Output of $mtrunk----
$mres
----EOF (\$?='$mret')----
END
}
if
(
$mres
eq
$lres
&&
$mret
==
$lret
) {
$lower
=
$number
;
warn
"Will binsearch the upper half\n"
;
}
else
{
$upper
=
$number
;
warn
"Will binsearch the lower half\n"
;
}
}
else
{
my
(
$next
) = findmiddlepatch(
$lower
,
$upper
);
unless
(
$next
) {
if
(
%NOSUCCESS
) {
warn
"No useable patch available between $lower and $upper\n"
;
die
sprintf
"Patches %s could not successfully be used to build perl\n"
,
join
(
", "
,
sort
{
$a
<=>
$b
}
keys
%NOSUCCESS
);
}
else
{
die
"No patch available between $lower and $upper\n"
;
}
}
local
$| = 1;
buildnext(
$next
);
redo
FINDMIDDLE;
}
}
}
sub
buildnext ($) {
my
(
$next
) =
@_
;
$APC
||= Perl::Repository::APC->new(
$Opt
{apcdir});
my
$branch
=
$Opt
{branch};
my
$lcheck
=
$APC
->closest(
$branch
,
"<"
,
$next
);
unless
(
$lcheck
==
$next
) {
my
$rcheck
=
$APC
->closest(
$branch
,
">"
,
$next
);
warn
"Patch $next not part of branch $branch.\n"
;
warn
"Closest left neighbor is $lcheck.\n"
if
$lcheck
;
warn
"Closest right neighbor is $rcheck.\n"
if
$rcheck
;
return
;
}
my
$perl
=
$APC
->get_from_version(
$branch
,
$next
);
my
$pver
=
$APC
->get_to_version(
$branch
,
$next
);
my
$config_opt
=
$Opt
{config} ?
" --config='$Opt{config}' "
:
""
;
my
$system
=
"buildaperl $config_opt --prefix='$Opt{prefix}' "
.
"--apcdir='$Opt{apcdir}' --branch='$branch' --notest $perl\@$next"
;
if
(
$Opt
{build}) {
if
(
$Opt
{maxbuild}) {
if
(
$built
>=
$Opt
{maxbuild}) {
printf
"NOT running $system, --maxbuild[%d] reached\n"
,
$Opt
{maxbuild};
exit
;
}
}
warn
"Will run
$system
\n";
if
(
system
(
$system
)==0 ) {
warn
" successful system[$system]\a\n"
;
$built
++;
}
else
{
if
(
$Opt
{
"die-on-error"
}) {
die
sprintf
"Error on building %s\@%s, "
.
"giving up due to 'die-on-error'"
,
$perl
,
$next
;
}
$NOSUCCESS
{
$next
}++;
}
sleep
3;
}
else
{
die
"No --build option set, giving up. Please run
$system
\n";
}
}
sub
findmiddleperl ($$) {
my
(
$lower
,
$upper
) =
@_
;
my
@sorted
= allperls(
$lower
+1,
$upper
-1) or
return
;
my
$switch
= 0;
while
(
@sorted
> 1) {
if
(
$switch
^= 1) {
pop
@sorted
;
}
else
{
shift
@sorted
;
}
}
return
$sorted
[0];
}
sub
allperls ($$) {
my
(
$lower
,
$upper
) =
@_
;
my
$bindir
=
"$Opt{prefix}/$Opt{branch}"
;
opendir
DIR,
$bindir
or
return
;
my
(
@cand
);
DIRENT:
for
my
$dirent
(
readdir
DIR) {
next
DIRENT
unless
$dirent
=~ /^p/;
opendir
DIR2,
"$bindir/$dirent"
or
next
;
DIRENT2:
for
my
$dirent2
(
readdir
DIR2) {
next
DIRENT2
unless
$dirent2
=~ /^perl-(\d+\.\d+\.\d+|\d\.\d\d\d_\d\d|0)\@(\d+)/;
my
$n
= $2;
next
DIRENT2
unless
$n
>=
$lower
&&
$n
<=
$upper
;
next
DIRENT2
unless
-d
"$bindir/$dirent/$dirent2"
;
next
DIRENT2
if
exists
$NOSUCCESS
{
$n
};
my
$perl
=
"$bindir/$dirent/$dirent2/bin/perl"
;
if
(-x
$perl
) {
if
(
my
$filter
=
$Opt
{cachefilter}) {
my
$ret
=
system
$perl
,
$filter
;
next
DIRENT2
unless
$ret
==0;
}
push
@cand
, [
$n
,
$perl
];
}
}
closedir
DIR2;
}
closedir
DIR;
return
unless
@cand
;
my
@sorted
=
sort
{
$a
->[0] <=>
$b
->[0] }
@cand
;
}
sub
findmiddlepatch ($$) {
my
(
$lower
,
$upper
) =
@_
;
$APC
||= Perl::Repository::APC->new(
$Opt
{apcdir});
my
(
@range
) = @{
$APC
->patch_range(
$Opt
{branch},
$lower
,
$upper
)};
@range
=
grep
{ !
exists
$NOSUCCESS
{
$_
} }
@range
;
return
unless
@range
;
pop
@range
;
return
unless
@range
;
shift
@range
;
return
unless
@range
;
if
(
%NOSUCCESS
) {
warn
"DEBUG: switching to random middlepoints between $lower and $upper (due to unsuccessful builds)"
;
return
$range
[
rand
@range
];
}
my
$switch
= 0;
while
(
@range
> 1) {
if
(
$switch
^= 1) {
pop
@range
;
}
else
{
shift
@range
;
}
}
return
$range
[0];
}
sub
findperl ($$) {
my
(
$id
) =
shift
;
my
(
$alt
) =
shift
;
die
"findperl called w/ illegal alt[$alt]"
unless
$alt
=~ /^[<>=]$/;
my
(
$lowest
,
$highest
,
$closest
,
$def_closest
,
$must_fit
);
if
(
$alt
eq
"="
) {
$def_closest
=
$closest
=
""
;
}
elsif
(
$alt
eq
"<"
) {
$def_closest
=
$closest
= 0;
}
elsif
(
$alt
eq
">"
) {
$def_closest
=
$closest
= 999999999;
}
DIRSEARCH: {
my
$bindir
=
sprintf
"%s/%s"
,
$Opt
{prefix},
$Opt
{branch};
my
@readdir
;
if
(
opendir
DIR,
$bindir
) {
@readdir
=
readdir
DIR;
closedir
DIR;
}
else
{
return
unless
$alt
eq
"="
;
}
DIRENT:
for
my
$dirent
(
@readdir
) {
next
unless
$dirent
=~ /^p/;
opendir
DIR2,
"$bindir/$dirent"
or
next
;
DIRENT2:
for
my
$dirent2
(
readdir
DIR2) {
next
unless
$dirent2
=~ /^perl-(0|\d+\.(?:\d+\.\d+|\d\d\d_\d\d))\@(\d+)/;
my
$thisperl
= $2;
next
unless
-d
"$bindir/$dirent/$dirent2"
;
if
(-x
"$bindir/$dirent/$dirent2/bin/perl"
) {
$highest
=
$lowest
=
$thisperl
unless
defined
$highest
||
defined
$lowest
;
$highest
=
$thisperl
if
$thisperl
>
$highest
;
$lowest
=
$thisperl
if
$thisperl
<
$lowest
;
if
(
$thisperl
eq
$id
){
return
"$bindir/$dirent/$dirent2/bin/perl"
,
$id
;
}
elsif
(
$alt
eq
"="
) {
next
DIRENT2;
}
else
{
my
$diff
=
$id
-
$thisperl
;
if
(
$alt
eq
"<"
&&
$diff
> 0) {
if
(
$id
-
$closest
>
$diff
) {
$closest
=
$thisperl
;
}
}
elsif
(
$alt
eq
">"
&&
$diff
< 0) {
if
(
$id
-
$closest
<
$diff
) {
$closest
=
$thisperl
;
}
}
}
}
else
{
warn
"\n\n+++ Found dirent $bindir/$dirent/$dirent2 "
.
"but no perl for it +++\n\n"
;
sleep
2;
}
}
closedir
DIR2;
}
if
(
$alt
eq
"="
) {
if
(
$must_fit
) {
warn
"No success in trying to build perl for $id"
for
0..4;
sleep
5;
return
(
undef
,
$id
);
}
else
{
buildnext(
$id
);
$must_fit
++;
redo
DIRSEARCH;
}
}
else
{
return
if
$closest
eq
$def_closest
;
$closest
=
$highest
if
$closest
>
$highest
;
$closest
=
$lowest
if
$closest
<
$lowest
;
warn
"Could not find a perl
for
patch ID
$id
, trying
$closest
.
Hint: to prevent version tolerance on initial test,
try
--exact-bounds.\n";
$id
=
$closest
;
redo
DIRSEARCH;
}
}
}