File Coverage

blib/lib/Perl/Repository/APC.pm

Criterion	Covered	Total	%
statement	21	308	6.8
branch	1	144	0.6
condition	0	27	0.0
subroutine	7	23	30.4
pod	12	12	100.0
total	41	514	7.9

package Perl::Repository::APC;

use strict;
use warnings;
use version;
use Cwd;
use File::Spec;
use Module::CoreList 2.14;

my $Id = q$Id: APC.pm 317 2011-03-26 16:59:05Z k $;
# our $VERSION = sprintf "2.000_%03d", substr(q$Rev: 317 $,4);
our $VERSION = "2.002001";
$VERSION =~ s/_//;

our %tarballs = (
                 "5.8.1" => {
                             tarfile => "perl-5.8.1.tar.gz",
                            },
                 "5.8.2" => {
                             tarfile => "perl-5.8.2.tar.gz",
                            },
                 "5.8.3" => {
                             tarfile => "perl-5.8.3.tar.gz",
                            },
                 "5.8.4" => {
                             tarfile => "perl-5.8.4.tar.gz",
                            },
                 "5.8.5" => {
                             tarfile => "perl-5.8.5.tar.gz",
                            },
                 "5.8.6" => {
                             tarfile => "perl-5.8.6.tar.gz",
                            },
                 "5.8.7" => {
                             tarfile => "perl-5.8.7.tar.gz",
                            },
                 "5.8.8" => {
                             tarfile => "perl-5.8.8.tar.gz",
                            },
                 "5.9.0" => {
                             tarfile => "perl-5.9.0.tar.gz",
                            },
                 "5.9.1" => {
                             tarfile => "perl-5.9.1.tar.gz",
                            },
                 "5.9.2" => {
                             tarfile => "perl-5.9.2.tar.gz",
                            },
                 "5.9.3" => {
                             tarfile => "perl-5.9.3.tar.gz",
                            },
                 "5.9.4" => {
                             tarfile => "perl-5.9.4.tar.gz",
                            },
                 "5.9.5" => {
                             tarfile => "perl-5.9.5.tar.gz",
                            },
                 "5.10.0" => {
                              tarfile => "perl-5.10.0.tar.gz",
                             },
                );

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 $dir =  shift;
  my $self;

  $self->{DIR} = $dir;
  $self->{APC} = [_apc_struct($dir)];

  bless $self => $class;
}

sub apcdirs {
  my($self) = @_;
  @{$self->{APC}};
}

sub tarball {
  unless (@_ == 2){
    require Carp;
    Carp::croak(sprintf "Not enough arguments for %s -> tarball ()\n", __PACKAGE__);
  }
  my($self,$pver) = @_;
  unless ($pver){
    require Carp;
    Carp::croak(sprintf "No version argument for %s -> tarball ()\n", __PACKAGE__);
  }

  my $DIR = File::Spec->catdir($self->{DIR},$pver);
  my $dir;
  unless (opendir $dir, $DIR) {
    return $self->_from_additional_tarballs($pver);
  }
  my(@dirent) = grep !/RC|TRIAL/, grep /^perl.*\.tar\.gz$/, readdir $dir;
  closedir $dir;
  if (@dirent>1){
      die "\aALERT: (\@dirent > 1: @dirent) in $pver" ;
  } elsif (@dirent==0) {
      return $self->_from_additional_tarballs($pver);
  }
  $dirent[0];
}

sub _from_additional_tarballs {
  my($self,$pver) = @_;
  die "unsupported perl version '$pver'", unless exists $tarballs{$pver};
  my $tarball = $tarballs{$pver}{tarfile};
  my $cwd = Cwd::cwd();
  my $addltar = File::Spec->catfile
      (
       $self->{DIR},
       "additional_tarballs",
       $tarball,
      );
  if (-f $addltar){
    return $addltar;
  } else {
    die "tarball '$tarball' not found. Have you mirrored the additional_tarballs directory?\n";
  }
}

sub patches {
  my($self,$ver) = @_;
  unless ($ver) {
    require Carp;
    Carp::confess("patches called without ver[$ver]");
  }
  my @res;
  for my $apcdir (@{$self->{APC}}) {
    my $pver = $apcdir->{perl};
    next unless $pver eq $ver;
    @res = @{$apcdir->{patches}};
    last;
  }
  \@res;
}

sub first_in_branch {
  my($self,$branch) = @_;
  unless (exists $self->{FIRST_IN_BRANCH}) {
    $self->next_in_branch; # initialize
  }
  my $ret = $self->{FIRST_IN_BRANCH}{$branch};
  die "Unknown branch" unless $ret;
  $ret;
}

sub next_in_branch {
  my($self,$ver) = @_;
  if (not exists $self->{NEXT_IN_BRANCH}) {
    my %L = ();
    for my $apcdir (@{$self->{APC}}) {
      my $pbranch = $apcdir->{branch};
      my $pver = $apcdir->{perl};
      $self->{NEXT_IN_BRANCH}{$pver} = [$pbranch]; # only for the last
      if ($L{$pbranch}){
        $self->{NEXT_IN_BRANCH}{$L{$pbranch}} = [$pbranch,$pver];
      } else {
        $self->{FIRST_IN_BRANCH}{$pbranch} = $pver;
      }
      $L{$pbranch} = $pver;
    }
  }
  return unless $ver;
  my $ref = $self->{NEXT_IN_BRANCH}{$ver};
  die "Unknown perl version $ver\n" unless $ref;
  my($rbranch,$rver) = @$ref;
  # warn "rver[$rver] rbranch[$rbranch]";
  $rver;
}

sub get_to_version {
  die "Usage: ->get_to_version(\$branch,\$patch)" unless @_ == 3;
  my($self,$branch,$patch) = @_;
  unless ($patch) {
    require Carp;
    Carp::confess("get_to_version called without patch[$patch]");
  }
  my $bp2v = $self->_bp2v;
  my $ret = $bp2v->{$branch,$patch};
  unless ($ret){
    require Carp;
    Carp::confess("patch[$patch] not part of branch[$branch]");
  }
  $ret;
}

sub get_diff_dir {
  die "Usage: ->get_diff_dir(\$branch,\$patch)" unless @_ == 3;
  my($self,$branch,$patch) = @_;
  my $perl = $self->get_to_version($branch,$patch);
  my $dir = $self->{PERL2DIR}{$perl};
  return $dir if $dir;
  my @apc = @{$self->{APC}};
  for my $apcdir (@apc) {
    my($dir) = $apcdir->{dir};
    my $abs = File::Spec->catdir($self->{DIR},$dir);
    unless (-d $abs) {
      $dir = $apcdir->{diffdir};
      $abs = File::Spec->catdir($self->{DIR},$dir);
      unless (-d $abs) {
        warn "WARNING: directory '$abs' not found";
      }
    }
    my($perl) = $apcdir->{perl};
    $self->{PERL2DIR}{$perl} = $dir;
  }
  die "could not find dir for perl '$self->{PERL2DIR}{$perl}'" unless $self->{PERL2DIR}{$perl};
  return $self->{PERL2DIR}{$perl};
}

sub _bp2v {
  my $self = shift;
  unless ($self->{BP2V}) { # branch/patch to version mapping
    my @apc = @{$self->{APC}};
    for my $apcdir (@apc) {
      my($apc_branch) = $apcdir->{branch};
      my($pver)       = $apcdir->{perl};
      my($patches)    = $apcdir->{patches};
      for my $p (@$patches) {
        $self->{BP2V}{$apc_branch,$p} = $pver;
      }
    }
  }
  $self->{BP2V};
}

sub get_from_version {
  my($self) = shift;
  my($branch,$patch) = @_;
  unless ($patch) {
    require Carp;
    $patch = "[undef]" unless defined $patch;
    Carp::confess("get_from_version called without patch[$patch]");
  }
  my $perl = $self->get_to_version(@_);
  my @apc = @{$self->{APC}};
  my %Ldir = ( "perl" => 0, "maint-5.004" => 0 );
  for my $apc (@apc) {
    my($apc_branch) = $apc->{branch};
    next unless $apc_branch eq $branch;
    my($pver) = $apc->{perl};
    if ($pver eq $perl) {
      if (exists $Ldir{$apc_branch}){
        return $Ldir{$apc_branch};
      } else {
        $perl =~ s/1$/0/;
        return $perl;
      }
    }
    $Ldir{$apc_branch} = $pver;
  }
}

{
  my %ignore = map { ($_ => undef) } qw(4475 32694);
  sub _ignore_patch_number ($) {
    my($patch_number) = @_;
    return exists $ignore{$patch_number};
  }
}

sub _apc_struct ($) {
  my $APC = shift;
  opendir my $APCDH, $APC or die "Could not open APC[$APC]: $!";
  my @apcdir;
  my %dseen;
  my %living_dirs = (
                     # all the "old" symlinks

## % ls -ld APC/*/diffs(@)
## lrwxrwxrwx 1 sand sand 21 2005-06-09 06:34:12 APC/5.005_04/diffs -> ../perl-5.005xx-diffs/
## lrwxrwxrwx 1 sand sand 19 2008-01-19 15:48:04 APC/5.6.2/diffs -> ../perl-5.6.2-diffs/
## lrwxrwxrwx 1 sand sand 19 2008-01-19 15:48:04 APC/5.6.3/diffs -> ../perl-5.6.x-diffs/
## lrwxrwxrwx 1 sand sand 19 2008-01-19 15:48:04 APC/5.8.1/diffs -> ../perl-5.8.x-diffs/
## lrwxrwxrwx 1 sand sand 21 2008-01-19 15:48:04 APC/5.9.0/diffs -> ../perl-current-diffs/

                     "5.005_04" => "perl-5.005xx-diffs",
                     "5.6.2"    => "perl-5.6.2-diffs",
                     "5.6.3"    => "perl-5.6.x-diffs",
                     "5.8.1"    => "perl-5.8.x-diffs",
                     "5.9.0"    => "perl-current-diffs",

                     # plus the not symlinked ones
                     "5.10.1"   => "perl-5.10.x-diffs",
                    );
  my %have_visited;
 DIRENT: for my $dirent (readdir $APCDH, keys %living_dirs) {
    next DIRENT unless $dirent =~ /^5/;
    my $diffdir;
    if (my $living_dir = $living_dirs{$dirent}) {
      $diffdir =  File::Spec->catdir($APC,$living_dir);
      unless (-e $diffdir) {
        my $fallback =  File::Spec->catdir($APC,$dirent,"diffs");
        warn "Warning: expected to find '$diffdir', trying '$fallback'";
        $diffdir = $fallback;
      }
    } else {
      $diffdir =  File::Spec->catdir($APC,$dirent,"diffs");
    }
    if ($have_visited{$dirent,$diffdir}++){
      # again is OK if for a different thing
      # warn "DEBUG: skipping '$diffdir' due to '$dirent'";
      next DIRENT;
    }
    opendir my $DIFFDIR, $diffdir or die "Could not open $diffdir: $!";
    my %patches;
    # read them and give them a value
  PFILE: for my $dirent2 (readdir $DIFFDIR) {
      next PFILE unless $dirent2 =~ /^(\d+)\.gz/;
      my $candnu = $1;
      next PFILE if _ignore_patch_number($candnu);
      $patches{$dirent2} = $candnu;
      if ($dseen{$dirent2}) {
        # warn "Duplicate $dirent2 in $diffdir (also in $dseen{$dirent2})\n";
      } else {
        $dseen{$dirent2} = $diffdir;
      }
    }
    closedir $DIFFDIR;
    unless (%patches){ # in case they did not mirror something we try to drop it silently
      # warn "DEBUG: skipping '$dirent' because no entry";
      next DIRENT;
    }
    my @patches = sort { $patches{$a} <=> $patches{$b} || $a cmp $b } keys %patches;
    my $branch;
    my $sortdummy;
  PATCH: for my $n (0..$#patches) {
      my $diff;
      die unless -e ($diff = File::Spec->catfile($diffdir,$patches[$n]));
      ($sortdummy) = $patches[$n] =~ /(\d+)/ unless $sortdummy;
      open my $fh, "zcat $diff |" or die;
      local($/) = "\n";
    LINE: while (<$fh>) {
        next LINE unless m|^==== //depot/([^/]+)/([^/]+)|;
        $branch = $1;
        my $subbranch = $2; # this limits us to one level. Unlucky.
        next LINE unless $branch =~ /maint/;
        $branch .= "/$subbranch" unless $subbranch eq "perl";
        last LINE;
        # print "$dirent|$patches[0]: $_";
      }
      close $fh;
      if ($branch) {
        last PATCH;
      }
    }
    my $reldiffdir = File::Spec->abs2rel($diffdir, $APC);
    unless ($reldiffdir) {
      warn "DEBUG: no reldiffdir??? dirent[$dirent]diffdir[$diffdir]";
    }
    push @apcdir, {branch  => $branch,
                   dir     => $dirent,
                   diffdir => $reldiffdir,
                   perl    => $dirent,
                   patches => [map {$patches{$patches[$_]}} 0..$#patches],
                  };
  }
  closedir $APCDH;
  _splice_additional_tarballs(\@apcdir);
  sort { $a->{patches}[-1] <=> $b->{patches}[-1] } @apcdir;
}

sub _splice_additional_tarballs ($) {
  my($apcdir) = @_;
  my @splicers;
  while (my($k,$v) = each %tarballs) {
    my $version = version->new($k)->numify + 0;
    my $x = $Module::CoreList::patchlevel{$version}
        or die "could not access corelist for '$version' from '$INC{'Module/CoreList.pm'}'";
    push @splicers, {
                     branch     => $x->[0],
                     patchlevel => $x->[1],
                     perl       => $k,
                    };
  }
  my $success = 0;
  for my $splicer (sort {$a->{branch} cmp $b->{branch}
                             ||
                                 $a->{patchlevel} <=> $b->{patchlevel}
                               } @splicers) {
  APCDIR: for my $i (0..$#$apcdir) {
      my $beq = $apcdir->[$i]{branch} eq $splicer->{branch};
      my $peq = version->new($splicer->{perl}) >= version->new($apcdir->[$i]{perl});
      my $lok = $splicer->{patchlevel} > $apcdir->[$i]{patches}[0];
      my $rok = $splicer->{patchlevel} <= $apcdir->[$i]{patches}[-1];
      if ($beq && $peq && $lok && $rok) {
        my $adir = splice @$apcdir, $i, 1;
        # the left range is leading to $version_popular
        # the right range is leading to what it already states
        my(%left, %right);
        for ("branch","dir","diffdir") {
          $left{$_} = $right{$_} = $adir->{$_};
        }
        if ($splicer->{perl} eq $adir->{perl}){
          # we cannot have two perls with the same name.
          $adir->{perl} .= ".1"; # ouch
        }
        $left{perl}     = $splicer->{perl};
        $right{perl}    = $adir->{perl};
        $left{patches}  = [];
        $right{patches} = [];
        push @{$left{patches}}, shift @{$adir->{patches}} while $adir->{patches}[0] <= $splicer->{patchlevel};
        $right{patches} = $adir->{patches};
        push @$apcdir, \%left, \%right;
        last APCDIR;
      }
    }
  }
  my %rename = (
                "5.8.1.1" => "5.8.9",
                "5.9.0.1" => "5.11.0",
               );
 APCDIR: for my $i (0..$#$apcdir) {
    my $perl = $apcdir->[$i]{perl};
    if (my $rename = $rename{$perl}) {
      $apcdir->[$i]{perl} = $rename;
    }
  }
}

sub version_range {
  my($self,$branch,$lo,$hi) = @_;
  $lo = $self->closest($branch,">",$lo);
  $hi = $self->closest($branch,"<",$hi);
  my @range;
  my @apc = @{$self->{APC}};
  for my $apcdir (@apc) {
    my($apc_branch) = $apcdir->{branch};
    my($pver) = $apcdir->{perl};
    my($patches) = $apcdir->{patches};
    next unless $apc_branch eq $branch;
    next unless $lo <= $patches->[-1];
    last if $hi < $patches->[0];
    push @range, $pver;
  }
  \@range;
}

sub patch_range {
  my($self,$branch,$lo,$hi) = @_;
  my($vrange,%vrange);
  $vrange = $self->version_range($branch,$lo,$hi);
  @vrange{@$vrange} = ();
  my @range;
  my @apc = @{$self->{APC}};
  for my $apcdir (@apc) {
    next unless exists $vrange{$apcdir->{perl}};
    my($patches) = $apcdir->{patches};
    for my $p (@$patches) {
      if ($p >= $lo && $p <= $hi) {
        push @range, $p;
      }
    }
  }
  \@range;
}

sub closest {
  my($self,$branch,$alt,$wanted) = @_;
  my $closest;
  if ($alt eq "<") {
    $closest = 0;
  } else {
    $closest = 999999999;
  }
  my @apc = @{$self->{APC}};
  for my $i (0..$#apc) {
    my $apcdir = $apc[$i];
    my($apc_branch) = $apcdir->{branch};
    my($pver) = $apcdir->{perl};
    my $patches = $apcdir->{patches};
    next unless $apc_branch eq $branch;
    next if $alt eq ">" && $patches->[-1] < $wanted;
    next if $alt eq "<" && $patches->[0] > $wanted;
    if ($alt eq ">" && $patches->[0] > $wanted){
      $closest = $patches->[0] if $closest > $patches->[0];
      last;
    } elsif ($alt eq "<" && $patches->[-1] < $wanted) {
      $closest = $patches->[-1];
      next;
    }
    for my $p (@$patches) {
      if ($alt eq "<") {
        last if $p > $wanted;
        $closest = $p;
      } else {
        $closest = $p, last if $p >= $wanted;
      }
    }
  }
  if ($alt eq "<") {
    if ($closest == 0) {
      die "Could not find a patch > 0 and < $wanted";
    }
  } else {
    if ($closest == 999999999) {
      die "Could not find a patch < 999999999 and > $wanted";
    }
  }
  $closest;
}

1;

__END__