#!/usr/bin/perl -w


# line 4

# XXX We should also rewrite runwithaps to be able to work with the
# new directory layout and we should supply configdiff.pl to our
# users.

use strict;

use Getopt::Long;
use Perl::Repository::APC;

our $Id = q$Id: binsearchaperl 62 2003-03-02 18:10:34Z k $;

our $APC;

our %Opt;
GetOptions(
           \%Opt,
           "apcdir=s",
           "bounds=s",
           "branch=s",
           "build!",
           "config=s",
           "exact-bounds=s",
           "maxbuild:i",
           "prefix=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=...              # where to find .tar.gz; defaults to "APC"
   --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
   --exact-bounds NNNN-NNNN  # as --bounds, but build the bounds if needed
   --h                       # This help page
   --maxbuild N              # How many perls to build
   --prefix=...              # prefix of the inst directory; default ./installed-perls
   --prog program
   --show-cache              # list all found perls sorted by patchlevel and exit
   --switches switches
   --verbose
   --version                 # show version and exit

Example:

    binsearch.pl --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"; # needed for show-cache

my $legal_branch = qr/^(?:perl|maint-(\d+\.\d+))$/;
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} ||= "";

our $built = 0;
while ($upper - $lower > 0) {
  my $id;
  (my $lperl,$id) = findperl($lower,$exact ? "=" : "<");
  if ($id) {
    $lower = $id;
  } 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,$id) = findperl($upper,$exact ? "=" : ">");
  if ($id) {
    $upper = $id;
  } else {
    my @offer = allperls(1,999999999);
    if (@offer) {
      warn "Highest perl in cache is $offer[-1][1],
 not suitable for upper bound $upper\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;
  my $lres = `$lperl $Opt{switches} $Opt{prog} 2>&1`;
  my $lret = $?;
  my $ures = `$uperl $Opt{switches} $Opt{prog} 2>&1`;
  my $uret = $?;
  if ($Opt{verbose}) {
    open my $fh, $Opt{prog} or die;
    local $/;
    my $prog = <$fh>;
    my $maxl = 34;
    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 \$?; cannot continue.
  lperl [$lperl]
  uperl [$uperl]
}
      if $lres eq $ures && $lret eq $uret; #};
  warn "Need a perl between $lower and $upper\n";
  $0 = "binsearchaperl: searching between $lower and $upper";
  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);
  }
  if (my($middle) = findmiddleperl($lower,$upper)) {
    my($number,$perl) = @$middle;
    warn "Found perl in the middle: number[$number]
 perl[$perl]\n";
    my $mres = `$perl $Opt{switches} $Opt{prog} 2>&1`;
    my $mret = $?;
    if ($mres eq $lres && $mret == $lret) {
      $lower = $number;
    } else {
      $upper = $number;
    }
  } 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";
      }
    }

    # XXX Please verify configuration equivalence with
    # perl bin/configdiff.pl $lperl $uperl\n";

    local $| = 1;
    buildnext($next);
  }
}

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 ) {
        # nothing to do?
        warn " successful system[$system]\a\n";
        $built++;
      } else {
        $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);
  for my $dirent (readdir DIR) {
    next unless $dirent =~ /^p/;
    opendir DIR2, "$bindir/$dirent" or next;
    for my $dirent2 (readdir DIR2) {
      next unless $dirent2 =~ /^perl-(\d+\.\d+\.\d+|\d\.\d\d\d_\d\d)\@(\d+)/;
      my $n = $2;
      next unless $n >= $lower && $n <= $upper;
      next unless -d "$bindir/$dirent/$dirent2";
      next if exists $NOSUCCESS{$n};
      if (-x "$bindir/$dirent/$dirent2/bin/perl") {
        push @cand, [$n, "$bindir/$dirent/$dirent2/bin/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: no success before, switching to random middlepoints";
    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 "=") {
            # warn "DEBUG: thisperl[$thisperl] id[$id]";
            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 {
          die "Found dirent $bindir/$dirent/$dirent2 but no perl for it";
        }
      }
      closedir DIR2;
    }
    if ($alt eq "=") {
      if ($must_fit) {
        die "No success in trying to build perl for $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;
    }
  }
}



=head1 NAME

binsearchaperl - binary search perl versions that exhibit changing behaviour

=head1 SYNOPSIS

 binsearchaperl --bounds 17000-18000 --prog testscript.pl --build
 binsearchaperl --show-cache
 binsearchaperl --h

=head1 DESCRIPTION

This script is built upon the buildaperl script and the
Perl::Repository::APC module and I< All Perl Changes >. You pass with
the --bounds or --exact-bounds option an interval of patch numbers and
with the --prog option a test script that exhibits some change in the
behaviour of perl. The script then does a binary search to determine
when exactly the change in behaviour occurred. It dies when it cannot
find or build any working perl anymore.

The --h option displays all available options.

The most convenient setup to run this script is just the same as
described in the buildaperl manpage.

Test programs are ideally written in a simple style that outputs "ok"
or "not ok", but you did know that already.

=head2 Caching in the install directory

Per default the underlying buildaperl script installs all resulting
perls for later perusal. binsearchaperl searches in the tree of
installed perls and uses them if they seem useful for a comparison.
The upside of this is faster execution, but the downside is that
binsearchaperl just looks at the branch and the patch number to
determine the usefulness of a cached perl. In case you work with the
C< --config > option and change these options sometimes, the result of
binsearchaperl may be wrong. It may happen that a difference in
behaviour is due to different config options and not merely to the
patch level. When in doubt, remove your whole installed-perls
directory or remove all perls compiled with irrelevant config options.

To help maintaining the cache, binsearchaperl can be given the
--show-cache option. With this option a list of all perls in the cache
is printed to STDOUT, sorted ascending by patch number, then the
script exits. A convenient usage of this list is these shell scripts:

  binsearchaperl --show-cache | while read p ; do
    echo $p;
    $p -V:usethreads
  done

or

  for p in `binsearchaperl --bounds 18700-99999 --show-cache` ; do
    echo $p;
    $p -V:config_args
  done

=head1 FAQ

=over

=item How can I run binary searches that need modules from CPAN?

The other day I used this shell script. If there are more efficient
ways, please let me know:


while true ; do
  for perl in `binsearchaperl --show-cache`
    do $perl -e '$m=shift; eval "require $m"
              or (require CPAN and CPAN::Shell->install($m))' 'Some::Module'
  done
  if ! binsearchaperl --verbose \
                      --build \
                      --maxbuild 1 \
                      --prog some_program.pl ; then
    break
  fi
done


=back

=head1 PREREQUISITES

Same prerequisites as mentioned in patchaperlup

=head1 AUTHOR

Andreas Koenig <andk@cpan.org>

=cut

