home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / CPANPLUS / Internals / Extract.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  7.6 KB  |  244 lines
  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:
  244.