File Coverage

blib/lib/Perl/Repository/APC/BAP.pm

Criterion	Covered	Total	%
statement	9	84	10.7
branch	0	54	0.0
condition	0	33	0.0
subroutine	3	6	50.0
pod	1	3	33.3
total	13	180	7.2

package Perl::Repository::APC::BAP;
use Perl::Repository::APC;

use strict;
use warnings;

my $Id = q$Id: BAP.pm 294 2008-02-22 10:42:30Z k $;
our $VERSION = sprintf "%.3f", 1 + substr(q$Rev: 294 $,4)/1000;

sub new {
  unless (@_ == 2){
    require Carp;
    Carp::croak(sprintf "Not enough arguments for %s -> new ()\n", __PACKAGE__);
  }
  my $proto   =  shift;
  my $class   =  ref $proto || $proto;

  my $apc =  shift;
  my $self;

  $self->{APC} = $apc;

  bless $self => $class;
}

sub translate {
  my($self,$branch,$baseperl,$patchlevel) = @_;
  die sprintf "%s -> translate called without a branch argument", __PACKAGE__
      unless $branch;
  my($prev, $nextperl, @patches, @ver);
  my $apc = $self->{APC};
  if ($branch eq "perl") {
    $prev = "0";
  } elsif (my($bv) = $branch =~ /^maint-(.*)/) {
    # maintainance nightmare: we currently (rev 123) have no access to
    # any metadata that tell us the perl we need
    if ($bv eq "5.004") {
      $prev = "0";
    } elsif ($branch =~ /\//) { # currently only "maint-5.6/perl-5.6.2"
      if ($branch eq "maint-5.6/perl-5.6.2") {
        $prev = "5.6.1";
      } else {
        die "Illegal value for branch[$branch]"; # carp doesn't make it better
      }
    } else {
      $prev = "$bv.0"; # 5.6 -> 5.6.0 etc.
    }
  }
  @ver = $prev;
  for (
       my $next = $apc->first_in_branch($branch);
       $next;
       $next = $apc->next_in_branch($next)
      ) {
    $nextperl = $next;
    @patches = @{$apc->patches($next)};
    push @ver, $next;
    if ($patchlevel && $patchlevel >= $patches[0] && $patchlevel <= $patches[-1]){
      if (defined $baseperl && length $baseperl &&
          grep { $_ eq $baseperl } @ver) {
        unless ($prev eq $baseperl){
          die "Fatal error: patch $patchlevel is outside the patchset based on $baseperl\n";
        }
      }
      last;
    } elsif (defined $baseperl && length($baseperl)) {
      if ($baseperl eq "0") {
        if ($ver[0] eq "0") {
          last;
        } else {
          die "Fatal error: 0 is not starting point for branch $branch\n";
        }
      } else {
        last if $prev && $baseperl eq $prev || @ver>1 && $baseperl eq $ver[-2];
      }
    }
    $prev = $next;
  }
  if (defined $baseperl && length $baseperl) {
    if ($baseperl eq "0") {
      # always OK?
    } else {
      unless (grep { $_ eq $baseperl } @ver){
        die "Fatal error: $baseperl is not part of branch $branch";
      }
    }
  } else {
    if (@ver > 1) {
      $baseperl = $ver[-2];
    } elsif (@ver == 1) {
      $baseperl = $ver[0];
      $baseperl =~ s/1$/0/;
    } else {
      die "Could not determine base perl version";
    }
  }
  if ($patchlevel) {
    unless (grep { $_ eq $patchlevel } @patches){
      my @neighbors = $self->neighbors($patchlevel,\@patches);
      my $tellmore;
      if (@neighbors) {
        if (@neighbors == 1) {
          $tellmore = "$neighbors[0] would be";
        } else {
          $tellmore = "$neighbors[0] or $neighbors[1] would be";
        }
      } else {
        $tellmore = "Range is from $patches[0] to $patches[-1]";
      }
      die "Fatal error: patch $patchlevel is not part of the patchset for $baseperl
    ($tellmore)\n";
    }
  } else {
    $patchlevel = $patches[-1];
  }
  my $firstpatch = $patches[0];
  my $dir = $apc->get_diff_dir($branch,$patchlevel);
  return ($baseperl, $nextperl, $firstpatch, $patchlevel, $dir);
}

sub neighbors {
  my($self,$x,$arr) = @_;
  return if $x < $arr->[0];
  return if $x > $arr->[-1];
  my @res;
  for my $i (0..$#$arr) {
    if ($arr->[$i] < $x) {
      $res[0] = $arr->[$i];
    } elsif ($arr->[$i] > $x) {
      $res[1] ||= $arr->[$i];
      last;
    } else {
      # must not happen
      die "Panic: neighbors called with matching element";
    }
  }
  @res;
}

1;

__END__