view release on metacpan or  search on metacpan

lib/CPAN/Site/Index.pm  view on Meta::CPAN

    \%dists;
}

sub remove_expired_details($$$)
{   my ($mycpan, $dists, $newer) = @_;
    trace "extracting only existing local distributions";

    my $authors = catdir $mycpan, 'authors', 'id';
    foreach my $dist (keys %$dists)
    {   my $fn = catfile $authors, $dist;
        if(! -f $fn)
        {   # removed local or a global dist
            delete $dists->{$dist};
        }
        elsif(-M $fn < $newer)
        {   trace "dist $dist file updated, reindexing";
            delete $dists->{$dist};
        }
    }
}

sub mkdirhier(@)
{   foreach my $dir (@_)
    {   next if -d $dir;
        mkdirhier dirname $dir;

        mkdir $dir, 0755
            or fault __x"cannot create directory {dir}", dir => $dir;

        trace "created $dir";
    }
    1;
}

sub cpan_mirror($$$@)
{   my ($mycpan, $globalcpan, $mods, %opts) = @_;
    @$mods or return;
    my %need = map { ($_ => 1) } @$mods;
    my $auth = catdir $mycpan, 'authors', 'id';

    unless($ua)
    {   $ua = LWP::UserAgent->new;
        $ua->env_proxy if $opts{env_proxy};
    }

    my $globdetails
             = update_global_cpan $mycpan, $globalcpan;

    my $fh   = IO::Zlib->new($globdetails, 'rb')
        or fault __x"cannot read from {fn}", fn => $globdetails;

    while(my $line = $fh->getline)   # skip header, search first blank
    {   last if $line =~ m/^\s*$/;
    }

    $ua ||= LWP::UserAgent->new;
    while(my $line = $fh->getline)
    {   my ($pkg, $version, $dist) = split ' ', $line;
        delete $need{$pkg} or next;

        my $to = catfile $auth, split m#/#, $dist;
        if(-f $to)
        {   trace __x"package {pkg} present in distribution {dist}"
              , pkg => $pkg, dist => $dist;
            next;
        }

        my $source   = "$globalcpan/authors/id/$dist";
        mkdirhier dirname $to;
        my $response = $ua->get($source, ':content_file' => $to);
        unless($response->is_success)
        {   unlink $to;
            error __x"failed to get {uri} for {to}: {err}"
              , uri => $source, to => $to, err => $response->status_line;
        }

        info __x"got {pkg} in {dist}", pkg => $pkg, dist => $dist;
    }

    warning __x"package {pkg} does not exist", pkg => $_
        for sort keys %need;
}

1;