view release on metacpan or  search on metacpan

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

    copy $from, $to
        or fault __x"cannot copy {from} to {to}", from => $from, to => $to;
}

sub cpan_index($@)
{   my ($mycpan, $globalcpan, %opts) = @_;
    my $lazy     = $opts{lazy};
    my $fallback = $opts{fallback};
    my $undefs   = exists $opts{undefs} ? $opts{undefs} : 1;

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

    -d $mycpan
        or error __x"archive top '{dir}' is not a directory"
             , dir => $mycpan;

    my $program     = basename $0;
    $VERSION      ||= 'undef';   # test env at home
    trace "$program version $VERSION";

    my $global      = catdir $mycpan, 'global';
    my $mods        = catdir $mycpan, 'modules';
    my $authors     = catdir $mycpan, 'authors';
    mkdirhier $global, $mods, $authors;

    my $globdetails = update_global_cpan $mycpan, $globalcpan;

    # Create mailrc and modlist

    safe_copy catfile($global, '01mailrc.txt.gz')
            , catfile($authors, '01mailrc.txt.gz');

    safe_copy catfile($global, '03modlist.data.gz')
            , catfile($mods, '03modlist.data.gz');

    # Create packages details

    my $details     = catfile $mods, '02packages.details.txt.gz';
    my $newlist     = catfile $mods, '02packages.details.tmp.gz';
    my $newer;

    my $reuse_dists = {};
    if($lazy && -f $details)
    {   $reuse_dists = read_details $details;
        $newer       = -M $details;
        remove_expired_details $mycpan, $reuse_dists, $newer;
    }

    my ($mypkgs, $distdirs)
      = package_inventory $mycpan, $reuse_dists, $newer;

    merge_global_cpan $mycpan, $mypkgs, $globdetails
        if $fallback;

    create_details $details, $newlist, $mypkgs, $lazy, $undefs;

    if(-f $details)
    {   trace "backup old details file to $details.bak";
        safe_copy $details, "$details.bak";
    }

    if(-f $newlist)
    {   trace "promoting $newlist to current";
        rename $newlist, $details
            or error __x"cannot rename '{from}' in '{to}'"
                 , from => $newlist, to => $details;
    }

    calculate_checksums $distdirs, catdir($mycpan, 'authors', 'id');
}

#
# Package Inventory
#

# global variables for testing purposes (sorry)
our ($topdir, $findpkgs, %finddirs, $olddists, $index_age);

sub register($$$)
{   my ($package, $this_version, $dist) = @_;

    # warn "register $package, " . (defined $this_version ? $this_version : 'undef');

    if(ref $this_version)
    {   eval { $this_version = version->parse($this_version) };
        if($@)
        {   alert __x"error when creating version object for {pkg}: {err}"
               , pkg => $package, err => $@;
            return;
        }
    }
      
    my $registered_version = exists $findpkgs->{$package} ? $findpkgs->{$package}[0] : undef;
    $this_version =~ s/^v// if $this_version;

    return if defined $registered_version
           && $registered_version > $this_version;

    $findpkgs->{$package} = [ $this_version, $dist ];
}

sub package_inventory($$;$)
{   (my $mycpan, $olddists, $index_age) = @_;   #!!! see "my"
    $topdir   = catdir $mycpan, 'authors', 'id';
    mkdirhier $topdir;

    $findpkgs = {};
    trace "creating inventory from $topdir";

    find {wanted => \&inspect_archive, no_chdir => 1}, $topdir;
    ($findpkgs, \%finddirs);
}

sub package_on_usual_location($)
{   my $file  = shift;
    my ($top, $subdir, @rest) = splitdir $file;
    defined $subdir or return 0;