File Coverage

lib/CPANPLUS/Internals/Extract.pm
Criterion Covered Total %
statement 75 85 88.2
branch 9 18 50.0
condition 4 11 36.3
subroutine 14 14 100.0
pod n/a
total 102 128 79.6


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