File Coverage

lib/CPANPLUS/Internals/Extract.pm
Criterion Covered Total %
statement 64 74 86.5
branch 7 16 43.8
condition 4 12 33.3
subroutine 11 11 100.0
pod n/a
total 86 113 76.1


line stmt bran cond sub pod time code
1             package CPANPLUS::Internals::Extract;
2              
3 15     15   235 use strict;
  15         236  
  15         237  
4              
5 15     15   236 use CPANPLUS::Error;
  15         316  
  15         401  
6 15     15   266 use CPANPLUS::Internals::Constants;
  15         137  
  15         413  
7              
8 15     15   597 use File::Spec ();
  15         140  
  15         149  
9 15     15   634 use File::Basename ();
  15         303  
  15         147  
10 15     15   665 use Archive::Extract;
  15         379  
  15         294  
11 15     15   307 use IPC::Cmd qw[run];
  15         139  
  15         319  
12 15     15   266 use Params::Check qw[check];
  15         137  
  15         2565  
13 15     15   314 use Module::Load::Conditional qw[can_load check_install];
  15         249  
  15         311  
14 15     15   280 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  15         172  
  15         262  
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 14     14   163     my $self = shift;
106 14         261     my $conf = $self->configure_object;
107 14         547     my %hash = @_;
108                 
109 14         176     local $Params::Check::ALLOW_UNKNOWN = 1;
110                 
111 14         150     my( $mod, $verbose, $force );
112 14         439     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 14 50       283     my $args = check( $tmpl, \%hash ) or return;
124                 
125             ### did we already extract it ? ###
126 14         229     my $loc = $mod->status->extract();
127                 
128 14 50 33     235     if( $loc && !$force ) {
129 0         0         msg(loc("Already extracted '%1' to '%2'. ".
130                             "Won't extract again without force",
131                             $mod->module, $loc), $verbose);
132 0         0         return $loc;
133                 }
134              
135             ### did we already fetch the file? ###
136 14         239     my $file = $mod->status->fetch();
137 14 50       798     unless( -s $file ) {
138 0         0         error( loc( "File '%1' has zero size: cannot extract", $file ) );
139 0         0         return;
140                 }
141              
142             ### the dir to extract to ###
143 14   33     749     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 14         1839     local $Archive::Extract::PREFER_BIN = $args->{'prefer_bin'};
153 14         218     local $Archive::Extract::DEBUG = $conf->get_conf('debug');
154 14         147     local $Archive::Extract::WARN = $verbose;
155              
156 14         1417     my $ae = Archive::Extract->new( archive => $file );
157              
158 14 50       1962     unless( $ae->extract( to => $to ) ) {
159 0         0         error( loc( "Unable to extract '%1' to '%2': %3",
160                                 $file, $to, $ae->error ) );
161 0         0         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 14 50       2756     unless ( $ae->files ) {
167 0 0       0         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 0         0         return;
172                 }
173                 
174                 
175             ### print out what files we extracted ###
176 14         1116     msg(loc("Extracted '%1'",$_),$verbose) for @{$ae->files};
  14         400  
  14         379  
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 14         712     for my $file ( @{$ae->files} ) {
  14         333  
186 140         8015         my $path = File::Spec->rel2abs( File::Spec->catdir($to, $file) );
187                 
188 140         37510         $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 14         2231     my $dir;
202 14         2109     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 14 50 33     5105         ($dir = $try) && last if -d $try;
207                 }
208                                                         
209             ### test if the dir exists ###
210 14 50 33     6153     unless( $dir && -d $dir ) {
211 0         0         error(loc("Unable to determine extract dir for '%1'",$mod->module));
212 0         0         return;
213                 
214                 } else {
215 14         1550         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 14         3724         $mod->status->extract( $dir );
220 14         339         $mod->status->files( $ae->files );
221                 }
222                   
223             ### also, figure out what kind of install we're dealing with ###
224 14         1018     $mod->get_installer_type();
225              
226 14         237     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:
237