view release on metacpan or  search on metacpan

lib/Perl/Repository/APC/BAP.pm  view on Meta::CPAN

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){