<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package CPANPLUS::Internals::Extract;
use deprecate;

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 =&gt; 'CPANPLUS', Style =&gt; 'gettext';

use vars qw[$VERSION];
$VERSION = "0.9135";

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

=pod

=head1 NAME

CPANPLUS::Internals::Extract - internals for archive extraction

=head1 SYNOPSIS

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

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

=head1 DESCRIPTION

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

The flow looks like this:

    $cb-&gt;_extract
        Delegate to Archive::Extract

=head1 METHODS

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

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

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

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

C&lt;_extract&gt; takes the following options:

=over 4

=item module

A C&lt;CPANPLUS::Module&gt; object. This is required.

=item extractdir

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

=item prefer_bin

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

=item perl

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

=item verbose

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

=item force

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

=back

All other options are passed on verbatim to C&lt;__unzip&gt; or C&lt;__untar&gt;.

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

=cut

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

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

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

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

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

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

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

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

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

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

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

    ### if -&gt;files is not filled, we dont know what the hell was
    ### extracted.. try to offer a suggestion and bail :(
    unless ( $ae-&gt;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-&gt;is_zip ? 'Archive::Zip' : 'Archive::Tar' ) );
        return;
    }


    ### print out what files we extracted ###
    msg(loc("Extracted '%1'",$_),$verbose) for @{$ae-&gt;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-&gt;rel2abs( File::Spec-&gt;catdir($to, $_) ) }
    #            @{$ae-&gt;files};

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

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

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

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

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

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

    return $mod-&gt;status-&gt;extract();
}

1;

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
</pre></body></html>