lib/CPANPLUS/Internals/Extract.pm

   1 package CPANPLUS::Internals::Extract;
   2
   3 use strict;
   4
   5 use CPANPLUS::Error;
   6 use CPANPLUS::Internals::Constants;
   7
   8 use File::Spec                  ();
   9 use File::Basename              ();
  10 use Archive::Extract;
  11 use IPC::Cmd                    qw[run];
  12 use Params::Check               qw[check];
  13 use Module::Load::Conditional   qw[can_load check_install];
  14 use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  15
  16 local $Params::Check::VERBOSE = 1;
  17
  18 =pod
  19
  20 =head1 NAME
  21
  22 CPANPLUS::Internals::Extract
  23
  24 =head1 SYNOPSIS
  25
  26     ### for source files ###
  27     $self->_gunzip( file => 'foo.gz', output => 'blah.txt' );
  28
  29     ### for modules/packages ###
  30     $dir = $self->_extract( module      => $modobj,
  31                             extractdir  => '/some/where' );
  32
  33 =head1 DESCRIPTION
  34
  35 CPANPLUS::Internals::Extract extracts compressed files for CPANPLUS.
  36 It can do this by either a pure perl solution (preferred) with the
  37 use of C<Archive::Tar> and C<Compress::Zlib>, or with binaries, like
  38 C<gzip> and C<tar>.
  39
  40 The flow looks like this:
  41
  42     $cb->_extract
  43         Delegate to Archive::Extract
  44
  45 =head1 METHODS
  46
  47 =head2 $dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] )
  48
  49 C<_extract> will take a module object and extract it to C<extractdir>
  50 if provided, or the default location which is obtained from your
  51 config.
  52
  53 The file name is obtained by looking at C<< $modobj->status->fetch >>
  54 and will be parsed to see if it's a tar or zip archive.
  55
  56 If it's a zip archive, C<__unzip> will be called, otherwise C<__untar>
  57 will be called. In the unlikely event the file is of neither format,
  58 an error will be thrown.
  59
  60 C<_extract> takes the following options:
  61
  62 =over 4
  63
  64 =item module
  65
  66 A C<CPANPLUS::Module> object. This is required.
  67
  68 =item extractdir
  69
  70 The directory to extract the archive to. By default this looks
  71 something like:
  72     /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME
  73
  74 =item prefer_bin
  75
  76 A flag indicating whether you prefer a pure perl solution, ie
  77 C<Archive::Tar> or C<Archive::Zip> respectively, or a binary solution
  78 like C<unzip> and C<tar>.
  79
  80 =item perl
  81
  82 The path to the perl executable to use for any perl calls. Also used
  83 to determine the build version directory for extraction.
  84
  85 =item verbose
  86
  87 Specifies whether to be verbose or not. Defaults to your corresponding
  88 config entry.
  89
  90 =item force
  91
  92 Specifies whether to force the extraction or not. Defaults to your
  93 corresponding config entry.
  94
  95 =back
  96
  97 All other options are passed on verbatim to C<__unzip> or C<__untar>.
  98
  99 Returns the directory the file was extracted to on success and false
 100 on failure.
 101
 102 =cut
 103
 104 sub _extract {
 105     my $self = shift;
 106     my $conf = $self->configure_object;
 107     my %hash = @_;
 108
 109     local $Params::Check::ALLOW_UNKNOWN = 1;
 110
 111     my( $mod, $verbose, $force );
 112     my $tmpl = {
 113         force       => { default => $conf->get_conf('force'),
 114                             store => \$force },
 115         verbose     => { default => $conf->get_conf('verbose'),
 116                             store => \$verbose },
 117         prefer_bin  => { default => $conf->get_conf('prefer_bin') },
 118         extractdir  => { default => $conf->get_conf('extractdir') },
 119         module      => { required => 1, allow => IS_MODOBJ, store => \$mod },
 120         perl        => { default => $^X },
 121     };
 122
 123     my $args = check( $tmpl, \%hash ) or return;
 124
 125     ### did we already extract it ? ###
 126     my $loc = $mod->status->extract();
 127
 128     if( $loc && !$force ) {
 129         msg(loc("Already extracted '%1' to '%2'. ".
 130                 "Won't extract again without force",
 131                 $mod->module, $loc), $verbose);
 132         return $loc;
 133     }
 134
 135     ### did we already fetch the file? ###
 136     my $file = $mod->status->fetch();
 137     unless( -s $file ) {
 138         error( loc( "File '%1' has zero size: cannot extract", $file ) );
 139         return;
 140     }
 141
 142     ### the dir to extract to ###
 143     my $to =    $args->{'extractdir'} ||
 144                 File::Spec->catdir(
 145                         $conf->get_conf('base'),
 146                         $self->_perl_version( perl => $args->{'perl'} ),
 147                         $conf->_get_build('moddir'),
 148                 );
 149
 150     ### delegate to Archive::Extract ###
 151     ### set up some flags for archive::extract ###
 152     local $Archive::Extract::PREFER_BIN = $args->{'prefer_bin'};
 153     local $Archive::Extract::DEBUG      = $conf->get_conf('debug');
 154     local $Archive::Extract::WARN       = $verbose;
 155
 156     my $ae = Archive::Extract->new( archive => $file );
 157
 158     unless( $ae->extract( to => $to ) ) {
 159         error( loc( "Unable to extract '%1' to '%2': %3",
 160                     $file, $to, $ae->error ) );
 161         return;
 162     }
 163
 164     ### if ->files is not filled, we dont know what the hell was
 165     ### extracted.. try to offer a suggestion and bail :(
 166     unless ( $ae->files ) {
 167         error( loc( "'%1' was not able to determine extracted ".
 168                     "files from the archive. Instal '%2' and ensure ".
 169                     "it works properly and try again",
 170                     $ae->is_zip ? 'Archive::Zip' : 'Archive::Tar' ) );
 171         return;
 172     }
 173
 174
 175     ### print out what files we extracted ###
 176     msg(loc("Extracted '%1'",$_),$verbose) for @{$ae->files};
 177
 178     ### set them all to be +w for the owner, so we don't get permission
 179     ### denied for overwriting files that are just +r
 180
 181     ### this is to rigurous -- just change to +w for the owner [cpan #13358]
 182     #chmod 0755, map { File::Spec->rel2abs( File::Spec->catdir($to, $_) ) }
 183     #            @{$ae->files};
 184
 185     for my $file ( @{$ae->files} ) {
 186         my $path = File::Spec->rel2abs( File::Spec->catdir($to, $file) );
 187
 188         $self->_mode_plus_w( file => $path );
 189     }
 190
 191     ### check the return value for the extracted path ###
 192     ### Make an educated guess if we didn't get an extract_path
 193     ### back
 194     ### XXX apparently some people make their own dists and they
 195     ### pack up '.' which means the leading directory is '.'
 196     ### and only the second directory is the actual module directory
 197     ### so, we'll have to check if our educated guess exists first,
 198     ### then see if the extract path works.. and if nothing works...
 199     ### well, then we really don't know.
 200
 201     my $dir;
 202     for my $try ( File::Spec->rel2abs( File::Spec->catdir(
 203                     $to, $mod->package_name .'-'. $mod->package_version ) ),
 204                   File::Spec->rel2abs( $ae->extract_path ),
 205     ) {
 206         ($dir = $try) && last if -d $try;
 207     }
 208
 209     ### test if the dir exists ###
 210     unless( $dir && -d $dir ) {
 211         error(loc("Unable to determine extract dir for '%1'",$mod->module));
 212         return;
 213
 214     } else {
 215         msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose);
 216
 217         ### register where we extracted the files to,
 218         ### also store what files were extracted
 219         $mod->status->extract( $dir );
 220         $mod->status->files( $ae->files );
 221     }
 222
 223     ### also, figure out what kind of install we're dealing with ###
 224     $mod->get_installer_type();
 225
 226     return $mod->status->extract();
 227 }
 228
 229 1;
 230
 231 # Local variables:
 232 # c-indentation-style: bsd
 233 # c-basic-offset: 4
 234 # indent-tabs-mode: nil
 235 # End:
 236 # vim: expandtab shiftwidth=4: