summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm247
1 files changed, 0 insertions, 247 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm
deleted file mode 100644
index 4028aacfa70..00000000000
--- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm
+++ /dev/null
@@ -1,247 +0,0 @@
-package CPANPLUS::Internals::Extract;
-use deprecate;
-
-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';
-
-use vars qw[$VERSION];
-$VERSION = "0.9135";
-
-local $Params::Check::VERBOSE = 1;
-
-=pod
-
-=head1 NAME
-
-CPANPLUS::Internals::Extract - internals for archive extraction
-
-=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. Install '%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 too rigorous -- 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: