File Coverage

lib/WorePAN.pm

Criterion	Covered	Total	%
statement	153	303	50.5
branch	34	144	23.6
condition	13	55	23.6
subroutine	24	41	58.5
pod	18	18	100.0
total	242	561	43.1

package WorePAN;

use strict;
use warnings;
use File::Temp ();
use Path::Extended::Tiny ();
use File::Spec;
use HTTP::Tiny;

our $VERSION = '0.17';

sub new {
  my ($class, %args) = @_;

  $args{verbose} = $ENV{TEST_VERBOSE} unless defined $args{verbose};

  if ($args{use_minicpan}) {
    eval { require CPAN::Mini } or die "requires CPAN::Mini";
    my %mini_config = CPAN::Mini->read_config;
    my $local = $mini_config{local};
    die "MiniCPAN not found" unless $local && -d $local;
    $args{root} = $local;
    $args{cleanup} = 0;
  }

  if (!$args{root}) {
    $args{root} = File::Temp::tempdir(CLEANUP => 1, ($args{tmp} ? (DIR => $args{tmp}) : TMPDIR => 1));
    warn "'root' is missing; created a temporary WorePAN directory: $args{root}\n" if $args{verbose};
  }
  $args{root} = Path::Extended::Tiny->new($args{root})->mkdir;
  $args{cpan} ||= "http://www.cpan.org/";
  if ($args{use_backpan}) {
    $args{backpan} ||= "http://backpan.cpan.org/";
  }
  $args{no_network} = 1 if !defined $args{no_network} && $ENV{HARNESS_ACTIVE};

  $args{pid} = $$;

  $args{ua} ||= HTTP::Tiny->new(
    agent => "WorePAN/$VERSION",
  );

  my $self = bless \%args, $class;

  my @files = @{ delete $self->{files} || [] };
  if (!$self->{no_network}) {
    if (my $dists = delete $self->{dists}) {
      push @files, $self->_dists2files($dists);
    }
  }
  # XXX: I don't think we need something like ->_mods2files, right?

  if (@files) {
    $self->_fetch(\@files);
    $self->update_indices(%args);
  }

  $self;
}

sub root { shift->{root} }
sub file {
  my $self = shift;
  my $file = $self->_normalize(File::Spec->catfile(@_)) or return;
  $self->{root}->file('authors/id', $file);
}
sub whois { shift->{root}->file('authors/00whois.xml') }
sub mailrc { shift->{root}->file('authors/01mailrc.txt.gz') }
sub packages_details { shift->{root}->file('modules/02packages.details.txt.gz') }

sub slurp_whois {
  my $self = shift;
  my $index = $self->whois;
  require Parse::CPAN::Whois;
  Parse::CPAN::Whois->new($index->path)->authors;
}

sub slurp_mailrc {
  my $self = shift;
  $self->_slurp($self->mailrc);
}
sub slurp_packages_details {
  my $self = shift;
  $self->_slurp($self->packages_details);
}

sub _slurp {
  my ($self, $index) = @_;
  return unless $index->exists;

  require IO::Zlib;
  my $fh = IO::Zlib->new($index->path, "rb") or die $!;
  my @lines;
  my $done_preambles;
  while(<$fh>) {
    chomp;
    if (/^\s*$/) {
      $done_preambles = 1;
      next;
    }
    next unless $done_preambles;
    push @lines, $_;
  }
  @lines;
}

sub add_files {
  my ($self, @files) = @_;
  $self->_fetch(\@files);
}

sub add_dists {
  my ($self, %dists) = @_;
  if ($self->{no_network}) {
    warn "requires network\n";
    return;
  }
  my @files = $self->_dists2files(\%dists);
  $self->_fetch(\@files);
}

sub _fetch {
  my ($self, $files) = @_;

  my %authors;
  my %packages;
  my $_root = $self->{root}->subdir('authors/id');
  for my $file (@$files) {
    my $dest;
    if (-f $file && $file =~ /\.(?:tar\.(?:gz|bz2)|tgz|zip)$/) {
      my $source = Path::Extended::Tiny->new($file);
      $dest = $_root->file('L/LO/LOCAL/', $source->basename);
      $self->_log("copy $source to $dest");
      $source->copy_to($dest);
      $dest->mtime($source->mtime);
    }
    else {
      $file = $self->_normalize($file) or next;
      $dest = $self->__fetch($file) or next;
    }
  }
}

sub _normalize {
  my ($self, $file) = @_;

  $file =~ s|\\|/|g if $^O eq 'MSWin32';

  if ($file !~ m{^([A-Z])/(\1[A-Z0-9_])/\2[A-Z0-9_\-]*/.+}) {
    if ($file =~ m{^([A-Z])([A-Z0-9_])[A-Z0-9_\-]*/.+}) {
      $file = "$1/$1$2/$file";
    }
    else {
      warn "unsupported file format: $file\n";
      return;
    }
  }
  return $file;
}

sub _dists2files {
  my ($self, $dists) = @_;
  return unless ref $dists eq ref {};

  require URI;
  require URI::QueryParam;
  require JSON::PP;

  my $uri = URI->new('http://api.cpanauthors.org/uploads/dist');
  my @keys = keys %$dists;
  my @files;
  while (@keys) {
    my @tmp = splice @keys, 0, 50;
    $uri->query_param(d => [
      map { $dists->{$_} ? "$_,$dists->{$_}" : $_ } @tmp
    ]);
    $self->_log("called API: $uri");
    my $res = $self->{ua}->get($uri);
    if (!$res->{success}) {
      warn "API error: $uri $res->{status} $res->{reason}";
      return;
    }
    my $rows = eval { JSON::PP::decode_json($res->{content}) };
    if ($@) {
      warn $@;
      return;
    }
    push @files, @$rows;
  }

  map {
    $_->{filename} && $_->{author}
      ? join '/',
          substr($_->{author}, 0, 1),
          substr($_->{author}, 0, 2),
          $_->{author},
          $_->{filename}
      : ()
  } @files;
}

sub _log {
  my ($self, $message) = @_;
  print STDERR "$message\n" if $self->{verbose};
}

sub __fetch {
  my ($self, $file) = @_;

  my $dest = $self->{root}->file("authors/id/", $file);
  return $dest if $dest->exists;

  $dest->parent->mkdir;

  if ($self->{local_mirror}) {
    my $source = Path::Extended::Tiny->new($self->{local_mirror}, "authors/id", $file);
    if ($source->exists) {
      $self->_log("copy $source to $dest");
      $source->copy_to($dest);
      $dest->mtime($source->mtime);
      return $dest;
    }
  }
  if (!$self->{no_network}) {
    my $url = $self->{cpan}."authors/id/$file";
    $self->_log("mirror $url to $dest");
    my $res = $self->{ua}->mirror($url => $dest);
    return $dest if $res->{success};
    if ($self->{backpan}) {
      my $url = $self->{backpan}."authors/id/$file";
      $self->_log("mirror $url to $dest");
      my $res = $self->{ua}->mirror($url => $dest);
      return $dest if $res->{success};
    }
  }
  warn "Can't fetch $file\n";
  return;
}

sub walk {
  my $self = shift;
  my %args = (@_ == 1 && ref $_[0] eq ref sub {})
    ? (callback => $_[0])
    : @_;
  my $root = $self->{root}->subdir('authors/id');
  my $tmproot = $self->{tmp} || $args{tmp};
  my $allow_dev_releases = $args{developer_releases} || $self->{developer_releases};

  require Archive::Any::Lite;

  local $Archive::Any::Lite::IGNORE_SYMLINK = 1;
  $root->recurse(callback => sub {
    my $archive_file = shift;
    return if -d $archive_file;

    my $path = $archive_file->relative($root);
    my $basename = $archive_file->basename;
    return unless $basename =~ /\.(?:tar\.(?:gz|bz2)|tgz|zip)$/;
    return if $basename =~ /^perl\-\d+/; # perls
    return if !$allow_dev_releases && (
         $basename =~ /\d\.\d+_\d/  # dev release
      or $basename =~ /TRIAL/       # trial release
    );

    my $archive = Archive::Any::Lite->new($archive_file->path);
    my $tmpdir = Path::Extended::Tiny->new(File::Temp::tempdir(CLEANUP => 1, ($tmproot ? (DIR => $tmproot) : (TMPDIR => 1))));
    $archive->extract($tmpdir);
    my $basedir = $tmpdir->children == 1 ? ($tmpdir->children)[0] : $tmpdir;
    $basedir = $tmpdir unless -d $basedir;

    $args{callback}->($basedir, $path, $archive_file);

    $tmpdir->remove;
  });
}

sub update_indices {
  my ($self, %args) = @_;

  return if $self->{no_indices};

  require IO::Zlib;
  require Parse::PMFile;
  require Parse::LocalDistribution;

  my $allow_dev_releases = $args{developer_releases} || $self->{developer_releases};
  my $permissions = $args{permissions} || $self->{permissions};

  my (%authors, %packages);
  $self->walk(%args, callback => sub {
    my ($basedir, $path, $archive_file) = @_;

    my $mtime = $archive_file->mtime;
    my ($author) = $path =~ m{^[A-Z]/[A-Z][A-Z0-9_]/([^/]+)/};
    $authors{$author} = 1;

    # a dist that has blib/ shouldn't be indexed
    # see PAUSE::dist::mail_summary
    return if $basedir->basename eq 'blib' or $basedir->subdir('blib')->exists;

    my $args = {ALLOW_DEV_VERSION => $allow_dev_releases};
    if ($permissions) {
      $args->{PERMISSIONS} = $permissions;
      $args->{USERID} = $author;
    }
    my $parser = Parse::LocalDistribution->new($args);
    my $info = $parser->parse($basedir);
    $self->_update_packages(\%packages, $info, $path, $mtime);
  });
  $self->_write_whois(\%authors);
  $self->_write_mailrc(\%authors);
  $self->_write_packages_details(\%packages);

  return 1;
}

sub _update_packages {
  my ($self, $packages, $info, $path, $mtime) = @_;

  for my $module (sort keys %$info) {
    next unless exists $info->{$module}{version};
    my $new_version = $info->{$module}{version};
    if (!$packages->{$module}) { # shortcut
      $packages->{$module} = [$new_version, $path, $mtime];
      next;
    }
    my $ok = 0;
    my $cur_version = $packages->{$module}[0];
    if (Parse::PMFile->_vgt($new_version, $cur_version)) {
      $ok++;
    }
    elsif (Parse::PMFile->_vgt($cur_version, $new_version)) {
      # lower VERSION number
    }
    else {
      no warnings; # numeric/version
      if (
        $new_version eq 'undef' or $new_version == 0 or
        Parse::PMFile->_vcmp($new_version, $cur_version) == 0
      ) {
        if ($mtime >= $packages->{$module}[2]) {
          $ok++; # dist is newer
        }
      }
    }
    if ($ok) {
      $packages->{$module} = [$new_version, $path, $mtime];
    }
  }
}

sub _write_whois {
  my ($self, $authors) = @_;

  my $index = $self->whois;
  $index->parent->mkdir;
  $index->openw;
  $index->printf(qq{\n\n}, scalar(gmtime), $VERSION);
  for my $id (sort keys %$authors) {
    $index->printf("%sauthor%s%s\@cpan.org1\n", $id, $id, lc $id);
  }
  $index->print("\n");
  $index->close;
  $self->_log("created $index");
}

sub _write_mailrc {
  my ($self, $authors) = @_;

  my $index = $self->mailrc;
  $index->parent->mkdir;
  my $fh = IO::Zlib->new($index->path, "wb") or die $!;
  for my $id (sort keys %$authors) {
    $fh->printf("alias %s \"%s <%s\@cpan.org>\"\n", $id, $id, lc $id);
  }
  $fh->close;
  $self->_log("created $index");
}

sub _write_packages_details {
  my ($self, $packages) = @_;

  my $index = $self->packages_details;
  $index->parent->mkdir;
  my $fh = IO::Zlib->new($index->path, "wb") or die $!;
  $fh->print("File: 02packages.details.txt\n");
  $fh->print("Last-Updated: ".localtime(time)."\n");
  $fh->print("\n");
  for my $pkg (map {$_->[1]} sort {($a->[0] cmp $b->[0]) || ($a->[1] cmp $b->[1])} map {[lc $_, $_]} keys %$packages) {
    my ($first, $second) = (30, 8);
    my $ver = defined $packages->{$pkg}[0] ? $packages->{$pkg}[0] : 'undef';
    if (length($pkg) > $first) {
      $second = length($ver);
      $first += 8 - $second;
    }
    $fh->printf("%-${first}s %${second}s  %s\n",
      $pkg,
      $ver,
      $packages->{$pkg}[1]
    );
  }
  $fh->close;
  $self->_log("created $index");
}

sub look_for {
  my ($self, $package) = @_;

  return unless defined $package;

  for ($self->slurp_packages_details) {
    if (/^$package\s+(\S+)\s+(\S+)$/) {
      return wantarray ? ($1, $2) : $1;
    }
  }
  return;
}

sub authors { shift->_authors_whois }

sub _authors_mailrc {
  my $self = shift;

  my @authors;
  for ($self->slurp_mailrc) {
    my ($id, $name, $email) = /^alias\s+(\S+)\s+"?(.+?)\s+(\S+?)"?\s*$/;
    next unless $id;
    $email =~ tr/<>//d;
    push @authors, {pauseid => $id, name => $name, email => $email};
  }
  \@authors;
}

sub _authors_whois {
  my $self = shift;

  my @authors;
  for ($self->slurp_whois) {
    push @authors, {
      pauseid => $_->pauseid,
      name => $_->name,
      asciiname => $_->asciiname,
      email => $_->email,
      homepage => $_->homepage,
    };
  }
  \@authors;
}

sub modules {
  my $self = shift;

  my @modules;
  for ($self->slurp_packages_details) {
    /^(\S+)\s+(\S+)\s+(\S+)/ or next;
    push @modules, {module => $1 ,version => $2 eq 'undef' ? undef : $2, file => $3};
  }
  \@modules;
}

sub files {
  my $self = shift;

  my %files;
  for ($self->slurp_packages_details) {
    /^\S+\s+\S+\s+(\S+)/ or next;
    $files{$1} = 1;
  }
  [keys %files];
}

sub latest_distributions {
  my $self = shift;

  require CPAN::DistnameInfo;

  my %dists;
  for my $file (@{ $self->files || [] }) {
    my $dist = CPAN::DistnameInfo->new($file);
    my $name = $dist->dist or next;
    if (
      !exists $dists{$name}
      or Parse::PMFile->_vlt($dists{$name}->version, $dist->version)
    ) {
      $dists{$name} = $dist;
    }
  }
  [values %dists];
}

sub DESTROY {
  my $self = shift;
  if ($self->{cleanup} && $$ == $self->{pid}) {
    $self->{root}->remove;
  }
}

1;

__END__