view release on metacpan or  search on metacpan

lib/CPAN/Unpack.pm  view on Meta::CPAN

package CPAN::Unpack;
use strict;
use warnings;
use Archive::Extract;
use Fcntl qw(:mode);
use File::Basename qw(basename);
use File::Find;
use File::Path;
use Parse::CPAN::Packages::Fast;
use YAML::Any ();
use base qw(Class::Accessor);
__PACKAGE__->mk_accessors(qw(cpan destination quiet));
$Archive::Extract::PREFER_BIN = 1;

our $VERSION = '0.31';

sub new {
    my $class = shift;
    my $self  = {};
    bless $self, $class;
    return $self;
}

sub unpack {
    my $self    = shift;
    my $counter = 0;

    my $cpan = $self->cpan;
    die "No $cpan" unless -d $cpan;

    my $destination = $self->destination;
    mkdir $destination;
    die "No $destination" unless -d $destination;

    my $packages_filename = "$cpan/modules/02packages.details.txt.gz";
    die "No packages at $packages_filename" unless -f $packages_filename;

    my %unpacked_versions;
    if ( -e "$destination/unpacked_versions.yml" ) {
        local $/;
        open( my $fh, "<", "$destination/unpacked_versions.yml" );
        %unpacked_versions = %{ YAML::Any::Load(<$fh>) };
        close $fh;
    }

    sub fixme {
        my $path = $_;
        my $mode = ( stat($path) )[2];
        if ( S_ISDIR($mode) ) {
            chmod( ( S_IMODE($mode) | S_IRWXU ), $path )
                unless ( ( $mode & S_IRWXU ) == S_IRWXU );
        }
    }
    my $p = Parse::CPAN::Packages::Fast->new($packages_filename);
    foreach my $distribution ( $p->latest_distributions ) {
        $counter++;
        my $want             = "$destination/" . $distribution->dist;
        my $archive_filename = "$cpan/authors/id/" . $distribution->prefix;

        unless ( -f $archive_filename ) {
            warn "Archive $archive_filename not found";
            next;
        }

        my $unpacked = $unpacked_versions{ $distribution->dist };

        if ( !defined( $distribution->version ) ) {

       # This is a bug in Parse::CPAN::Packages (and ::Fast). It affects a few
       # dozen packages, so use the mtime as version
            $unpacked_versions{ $distribution->dist }
                = "x" . ( stat $archive_filename )[9];
        } else {
            $unpacked_versions{ $distribution->dist }
                = "x" . $distribution->version;
        }

        if ( defined($unpacked)
            && $unpacked eq $unpacked_versions{ $distribution->dist } 
            && -d $want )
        {
            next;
        }

        if ( -d $want ) {
            print "Deleting old version of " . $distribution->dist . "\n"
                unless $self->quiet;
            rmtree $want;
        }

        print "Unpacking " . $distribution->prefix . " ($counter)\n"
            unless $self->quiet;

        my $extract = Archive::Extract->new( archive => $archive_filename );
        my $to = "$destination/test";
        rmtree($to);
        mkdir($to);
        $extract->extract( to => $to );

        # Fix up broken permissions
        File::Find::find( { wanted => \&fixme, follow => 0, no_chdir => 1 },
            $to );

        my @files = <$to/*>;
        my $files = @files;
        if ( $files == 1 ) {
            my $file = $files[0];
            if ( S_ISDIR( ( stat( $file ) )[2] ) ) {
                rename $file, $want;
            } else {