diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm')
| -rwxr-xr-x | Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm | 243 |
1 files changed, 243 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm new file mode 100755 index 00000000000..84a48a50dea --- /dev/null +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm @@ -0,0 +1,243 @@ +package CPANPLUS::Internals::Extract; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use File::Spec (); +use File::Basename (); +use Archive::Extract; +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Extract + +=head1 SYNOPSIS + + ### for source files ### + $self->_gunzip( file => 'foo.gz', output => 'blah.txt' ); + + ### for modules/packages ### + $dir = $self->_extract( module => $modobj, + extractdir => '/some/where' ); + +=head1 DESCRIPTION + +CPANPLUS::Internals::Extract extracts compressed files for CPANPLUS. +It can do this by either a pure perl solution (preferred) with the +use of C<Archive::Tar> and C<Compress::Zlib>, or with binaries, like +C<gzip> and C<tar>. + +The flow looks like this: + + $cb->_extract + Delegate to Archive::Extract + +=head1 METHODS + +=head2 $dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] ) + +C<_extract> will take a module object and extract it to C<extractdir> +if provided, or the default location which is obtained from your +config. + +The file name is obtained by looking at C<< $modobj->status->fetch >> +and will be parsed to see if it's a tar or zip archive. + +If it's a zip archive, C<__unzip> will be called, otherwise C<__untar> +will be called. In the unlikely event the file is of neither format, +an error will be thrown. + +C<_extract> takes the following options: + +=over 4 + +=item module + +A C<CPANPLUS::Module> object. This is required. + +=item extractdir + +The directory to extract the archive to. By default this looks +something like: + /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME + +=item prefer_bin + +A flag indicating whether you prefer a pure perl solution, ie +C<Archive::Tar> or C<Archive::Zip> respectively, or a binary solution +like C<unzip> and C<tar>. + +=item perl + +The path to the perl executable to use for any perl calls. Also used +to determine the build version directory for extraction. + +=item verbose + +Specifies whether to be verbose or not. Defaults to your corresponding +config entry. + +=item force + +Specifies whether to force the extraction or not. Defaults to your +corresponding config entry. + +=back + +All other options are passed on verbatim to C<__unzip> or C<__untar>. + +Returns the directory the file was extracted to on success and false +on failure. + +=cut + +sub _extract { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + local $Params::Check::ALLOW_UNKNOWN = 1; + + my( $mod, $verbose, $force ); + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + prefer_bin => { default => $conf->get_conf('prefer_bin') }, + extractdir => { default => $conf->get_conf('extractdir') }, + module => { required => 1, allow => IS_MODOBJ, store => \$mod }, + perl => { default => $^X }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### did we already extract it ? ### + my $loc = $mod->status->extract(); + + if( $loc && !$force ) { + msg(loc("Already extracted '%1' to '%2'. ". + "Won't extract again without force", + $mod->module, $loc), $verbose); + return $loc; + } + + ### did we already fetch the file? ### + my $file = $mod->status->fetch(); + unless( -s $file ) { + error( loc( "File '%1' has zero size: cannot extract", $file ) ); + return; + } + + ### the dir to extract to ### + my $to = $args->{'extractdir'} || + File::Spec->catdir( + $conf->get_conf('base'), + $self->_perl_version( perl => $args->{'perl'} ), + $conf->_get_build('moddir'), + ); + + ### delegate to Archive::Extract ### + ### set up some flags for archive::extract ### + local $Archive::Extract::PREFER_BIN = $args->{'prefer_bin'}; + local $Archive::Extract::DEBUG = $conf->get_conf('debug'); + local $Archive::Extract::WARN = $verbose; + + my $ae = Archive::Extract->new( archive => $file ); + + unless( $ae->extract( to => $to ) ) { + error( loc( "Unable to extract '%1' to '%2': %3", + $file, $to, $ae->error ) ); + return; + } + + ### if ->files is not filled, we dont know what the hell was + ### extracted.. try to offer a suggestion and bail :( + unless ( $ae->files ) { + error( loc( "'%1' was not able to determine extracted ". + "files from the archive. Instal '%2' and ensure ". + "it works properly and try again", + $ae->is_zip ? 'Archive::Zip' : 'Archive::Tar' ) ); + return; + } + + + ### print out what files we extracted ### + msg(loc("Extracted '%1'",$_),$verbose) for @{$ae->files}; + + ### set them all to be +w for the owner, so we don't get permission + ### denied for overwriting files that are just +r + + ### this is to rigurous -- just change to +w for the owner [cpan #13358] + #chmod 0755, map { File::Spec->rel2abs( File::Spec->catdir($to, $_) ) } + # @{$ae->files}; + + for my $file ( @{$ae->files} ) { + my $path = File::Spec->rel2abs( File::Spec->catfile($to, $file) ); + + $self->_mode_plus_w( file => $path ); + } + + ### check the return value for the extracted path ### + ### Make an educated guess if we didn't get an extract_path + ### back + ### XXX apparently some people make their own dists and they + ### pack up '.' which means the leading directory is '.' + ### and only the second directory is the actual module directory + ### so, we'll have to check if our educated guess exists first, + ### then see if the extract path works.. and if nothing works... + ### well, then we really don't know. + + my $dir; + for my $try ( + File::Spec->rel2abs( + ### _safe_path must be called before catdir because catdir on + ### VMS currently will not handle the extra dots in the directories. + File::Spec->catdir( $self->_safe_path( path => $to ) , + $self->_safe_path( path => + $mod->package_name .'-'. + $mod->package_version + ) ) ) , + File::Spec->rel2abs( $ae->extract_path ), + ) { + ($dir = $try) && last if -d $try; + } + + ### test if the dir exists ### + unless( $dir && -d $dir ) { + error(loc("Unable to determine extract dir for '%1'",$mod->module)); + return; + + } else { + msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose); + + ### register where we extracted the files to, + ### also store what files were extracted + $mod->status->extract( $dir ); + $mod->status->files( $ae->files ); + } + + ### also, figure out what kind of install we're dealing with ### + $mod->get_installer_type(); + + return $mod->status->extract(); +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: |