1 package CPANPLUS::Internals::Extract;
6 use CPANPLUS::Internals::Constants;
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';
16 local $Params::Check::VERBOSE = 1;
22 CPANPLUS::Internals::Extract
26 ### for source files ###
27 $self->_gunzip( file => 'foo.gz', output => 'blah.txt' );
29 ### for modules/packages ###
30 $dir = $self->_extract( module => $modobj,
31 extractdir => '/some/where' );
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
40 The flow looks like this:
43 Delegate to Archive::Extract
47 =head2 $dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] )
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
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.
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.
60 C<_extract> takes the following options:
66 A C<CPANPLUS::Module> object. This is required.
70 The directory to extract the archive to. By default this looks
72 /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME
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>.
82 The path to the perl executable to use for any perl calls. Also used
83 to determine the build version directory for extraction.
87 Specifies whether to be verbose or not. Defaults to your corresponding
92 Specifies whether to force the extraction or not. Defaults to your
93 corresponding config entry.
97 All other options are passed on verbatim to C<__unzip> or C<__untar>.
99 Returns the directory the file was extracted to on success and false
106 my $conf = $self->configure_object;
109 local $Params::Check::ALLOW_UNKNOWN = 1;
111 my( $mod, $verbose, $force );
113 force => { default => $conf->get_conf('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 },
123 my $args = check( $tmpl, \%hash ) or return;
125 ### did we already extract it ? ###
126 my $loc = $mod->status->extract();
128 if( $loc && !$force ) {
129 msg(loc("Already extracted '%1' to '%2'. ".
130 "Won't extract again without force",
131 $mod->module, $loc), $verbose);
135 ### did we already fetch the file? ###
136 my $file = $mod->status->fetch();
138 error( loc( "File '%1' has zero size: cannot extract", $file ) );
142 ### the dir to extract to ###
143 my $to = $args->{'extractdir'} ||
145 $conf->get_conf('base'),
146 $self->_perl_version( perl => $args->{'perl'} ),
147 $conf->_get_build('moddir'),
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;
156 my $ae = Archive::Extract->new( archive => $file );
158 unless( $ae->extract( to => $to ) ) {
159 error( loc( "Unable to extract '%1' to '%2': %3",
160 $file, $to, $ae->error ) );
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' ) );
175 ### print out what files we extracted ###
176 msg(loc("Extracted '%1'",$_),$verbose) for @{$ae->files};
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
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, $_) ) }
185 for my $file ( @{$ae->files} ) {
186 my $path = File::Spec->rel2abs( File::Spec->catfile($to, $file) );
188 $self->_mode_plus_w( file => $path );
191 ### check the return value for the extracted path ###
192 ### Make an educated guess if we didn't get an extract_path
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.
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
211 File::Spec->rel2abs( $ae->extract_path ),
213 ($dir = $try) && last if -d $try;
216 ### test if the dir exists ###
217 unless( $dir && -d $dir ) {
218 error(loc("Unable to determine extract dir for '%1'",$mod->module));
222 msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose);
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 );
230 ### also, figure out what kind of install we're dealing with ###
231 $mod->get_installer_type();
233 return $mod->status->extract();
239 # c-indentation-style: bsd
241 # indent-tabs-mode: nil
243 # vim: expandtab shiftwidth=4: