CPANPLUS::Internals::Extract - CPANPLUS::Internals::Extract documentation

CPANPLUS documentation Contained in the CPANPLUS distribution.

Index

Code Index:

NAME

Top

CPANPLUS::Internals::Extract

SYNOPSIS

Top

    ### for source files ###
    $self->_gunzip( file => 'foo.gz', output => 'blah.txt' );

    ### for modules/packages ###
    $dir = $self->_extract( module      => $modobj,
                            extractdir  => '/some/where' );

DESCRIPTION

Top

CPANPLUS::Internals::Extract extracts compressed files for CPANPLUS. It can do this by either a pure perl solution (preferred) with the use of Archive::Tar and Compress::Zlib, or with binaries, like gzip and tar.

The flow looks like this:

    $cb->_extract
        Delegate to Archive::Extract

METHODS

Top

$dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] )

_extract will take a module object and extract it to extractdir if provided, or the default location which is obtained from your config.

The file name is obtained by looking at $modobj->status->fetch and will be parsed to see if it's a tar or zip archive.

If it's a zip archive, __unzip will be called, otherwise __untar will be called. In the unlikely event the file is of neither format, an error will be thrown.

_extract takes the following options:

module

A CPANPLUS::Module object. This is required.

extractdir

The directory to extract the archive to. By default this looks something like: /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME

prefer_bin

A flag indicating whether you prefer a pure perl solution, ie Archive::Tar or Archive::Zip respectively, or a binary solution like unzip and tar.

perl

The path to the perl executable to use for any perl calls. Also used to determine the build version directory for extraction.

verbose

Specifies whether to be verbose or not. Defaults to your corresponding config entry.

force

Specifies whether to force the extraction or not. Defaults to your corresponding config entry.

All other options are passed on verbatim to __unzip or __untar.

Returns the directory the file was extracted to on success and false on failure.

CPANPLUS documentation Contained in the CPANPLUS distribution. 
package CPANPLUS::Internals::Extract;

use strict;

use CPANPLUS::Error;
use CPANPLUS::Internals::Constants;

use File::Spec                  ();
use File::Basename              ();
use Archive::Extract;
use IPC::Cmd                    qw[run];
use Params::Check               qw[check];
use Module::Load::Conditional   qw[can_load check_install];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

local $Params::Check::VERBOSE = 1;


sub _extract {
    my $self = shift;
    my $conf = $self->configure_object;
    my %hash = @_;

    local $Params::Check::ALLOW_UNKNOWN = 1;

    my( $mod, $verbose, $force );
    my $tmpl = {
        force       => { default => $conf->get_conf('force'),
                            store => \$force },
        verbose     => { default => $conf->get_conf('verbose'),
                            store => \$verbose },
        prefer_bin  => { default => $conf->get_conf('prefer_bin') },
        extractdir  => { default => $conf->get_conf('extractdir') },
        module      => { required => 1, allow => IS_MODOBJ, store => \$mod },
        perl        => { default => $^X },
    };

    my $args = check( $tmpl, \%hash ) or return;

    ### did we already extract it ? ###
    my $loc = $mod->status->extract();

    if( $loc && !$force ) {
        msg(loc("Already extracted '%1' to '%2'. ".
                "Won't extract again without force",
                $mod->module, $loc), $verbose);
        return $loc;
    }

    ### did we already fetch the file? ###
    my $file = $mod->status->fetch();
    unless( -s $file ) {
        error( loc( "File '%1' has zero size: cannot extract", $file ) );
        return;
    }

    ### the dir to extract to ###
    my $to =    $args->{'extractdir'} ||
                File::Spec->catdir(
                        $conf->get_conf('base'),
                        $self->_perl_version( perl => $args->{'perl'} ),
                        $conf->_get_build('moddir'),
                );

    ### delegate to Archive::Extract ###
    ### set up some flags for archive::extract ###
    local $Archive::Extract::PREFER_BIN = $args->{'prefer_bin'};
    local $Archive::Extract::DEBUG      = $conf->get_conf('debug');
    local $Archive::Extract::WARN       = $verbose;

    my $ae = Archive::Extract->new( archive => $file );

    unless( $ae->extract( to => $to ) ) {
        error( loc( "Unable to extract '%1' to '%2': %3",
                    $file, $to, $ae->error ) );
        return;
    }

    ### if ->files is not filled, we dont know what the hell was
    ### extracted.. try to offer a suggestion and bail :(
    unless ( $ae->files ) {
        error( loc( "'%1' was not able to determine extracted ".
                    "files from the archive. Install '%2' and ensure ".
                    "it works properly and try again",
                    $ae->is_zip ? 'Archive::Zip' : 'Archive::Tar' ) );
        return;
    }


    ### print out what files we extracted ###
    msg(loc("Extracted '%1'",$_),$verbose) for @{$ae->files};

    ### set them all to be +w for the owner, so we don't get permission
    ### denied for overwriting files that are just +r

    ### this is too rigorous -- just change to +w for the owner [cpan #13358]
    #chmod 0755, map { File::Spec->rel2abs( File::Spec->catdir($to, $_) ) }
    #            @{$ae->files};

    for my $file ( @{$ae->files} ) {
        my $path = File::Spec->rel2abs( File::Spec->catfile($to, $file) );

        $self->_mode_plus_w( file => $path );
    }

    ### check the return value for the extracted path ###
    ### Make an educated guess if we didn't get an extract_path
    ### back
    ### XXX apparently some people make their own dists and they
    ### pack up '.' which means the leading directory is '.'
    ### and only the second directory is the actual module directory
    ### so, we'll have to check if our educated guess exists first,
    ### then see if the extract path works.. and if nothing works...
    ### well, then we really don't know.

    my $dir;
    for my $try (
        File::Spec->rel2abs(
            ### _safe_path must be called before catdir because catdir on
            ### VMS currently will not handle the extra dots in the directories.
            File::Spec->catdir( $self->_safe_path( path => $to ) ,
                                $self->_safe_path( path =>
                                             $mod->package_name .'-'.
                                             $mod->package_version
        ) ) ) ,
        File::Spec->rel2abs( $ae->extract_path ),
    ) {
        ($dir = $try) && last if -d $try;
    }

    ### test if the dir exists ###
    unless( $dir && -d $dir ) {
        error(loc("Unable to determine extract dir for '%1'",$mod->module));
        return;

    } else {
        msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose);

        ### register where we extracted the files to,
        ### also store what files were extracted
        $mod->status->extract( $dir );
        $mod->status->files( $ae->files );
    }

    ### also, figure out what kind of install we're dealing with ###
    $mod->get_installer_type();

    return $mod->status->extract();
}

1;

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4: