[Summary view] [Print] [Text view]

   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->catfile($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 (
 203          File::Spec->rel2abs( 
 204              ### _safe_path must be called before catdir because catdir on 
 205              ### VMS currently will not handle the extra dots in the directories.
 206              File::Spec->catdir( $self->_safe_path( path => $to ) ,  
 207                                  $self->_safe_path( path =>
 208                                               $mod->package_name .'-'. 
 209                                               $mod->package_version
 210          ) ) ) ,
 211          File::Spec->rel2abs( $ae->extract_path ),
 212      ) {
 213          ($dir = $try) && last if -d $try;
 214      }
 215                                              
 216      ### test if the dir exists ###
 217      unless( $dir && -d $dir ) {
 218          error(loc("Unable to determine extract dir for '%1'",$mod->module));
 219          return;
 220      
 221      } else {    
 222          msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose);
 223          
 224          ### register where we extracted the files to,
 225          ### also store what files were extracted
 226          $mod->status->extract( $dir ); 
 227          $mod->status->files( $ae->files );
 228      }
 229        
 230      ### also, figure out what kind of install we're dealing with ###
 231      $mod->get_installer_type();
 232  
 233      return $mod->status->extract();
 234  }
 235  
 236  1;
 237  
 238  # Local variables:
 239  # c-indentation-style: bsd
 240  # c-basic-offset: 4
 241  # indent-tabs-mode: nil
 242  # End:
 243  # vim: expandtab shiftwidth=4: