view release on metacpan or  search on metacpan

inc/inc_Archive-Extract/Archive/Extract.pm  view on Meta::CPAN

    {   my $use_list = { 'Archive::Tar' => '0.0' };

        unless( can_load( modules => $use_list ) ) {

            return $self->_error(loc("You do not have '%1' installed - " .
                                 "Please install it as soon as possible.",
                                 'Archive::Tar'));
        }
    }

    ### we might pass it a filehandle if it's a .tbz file..
    my $fh_to_read = $self->archive;

    ### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib
    ### if A::T's version is 0.99 or higher
    if( $self->is_tgz ) {
        my $use_list = { 'Compress::Zlib' => '0.0' };
           $use_list->{ 'IO::Zlib' } = '0.0'
                if $Archive::Tar::VERSION >= '0.99';

        unless( can_load( modules => $use_list ) ) {
            my $which = join '/', sort keys %$use_list;

            return $self->_error(loc(
                                "You do not have '%1' installed - Please ".
                                "install it as soon as possible.", $which));

        }
    } elsif ( $self->is_tbz ) {
        my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
        unless( can_load( modules => $use_list ) ) {
            return $self->_error(loc(
                    "You do not have '%1' installed - Please " .
                    "install it as soon as possible.", 
                     'IO::Uncompress::Bunzip2'));
        }

        my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
            return $self->_error(loc("Unable to open '%1': %2",
                            $self->archive,
                            $IO::Uncompress::Bunzip2::Bunzip2Error));

        $fh_to_read = $bz;
    }

    my $tar = Archive::Tar->new();

    ### only tell it it's compressed if it's a .tgz, as we give it a file
    ### handle if it's a .tbz
    unless( $tar->read( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) ) ) {
        return $self->_error(loc("Unable to read '%1': %2", $self->archive,
                                    $Archive::Tar::error));
    }

    ### workaround to prevent Archive::Tar from setting uid, which
    ### is a potential security hole. -autrijus
    ### have to do it here, since A::T needs to be /loaded/ first ###
    {   no strict 'refs'; local $^W;

        ### older versions of archive::tar <= 0.23
        *Archive::Tar::chown = sub {};
    }

    ### for version of archive::tar > 1.04
    local $Archive::Tar::Constant::CHOWN = 0;

    {   local $^W;  # quell 'splice() offset past end of array' warnings
                    # on older versions of A::T

        ### older archive::tar always returns $self, return value slightly
        ### fux0r3d because of it.
        $tar->extract()
            or return $self->_error(loc("Unable to extract '%1': %2",
                                    $self->archive, $Archive::Tar::error ));
    }

    my @files   = $tar->list_files;
    my $dir     = $self->__get_extract_dir( \@files );

    ### store the files that are in the archive ###
    $self->files(\@files);

    ### store the extraction dir ###
    $self->extract_path( $dir );

    ### check if the dir actually appeared ###
    return 1 if -d $self->extract_path;

    ### no dir, we failed ###
    return $self->_error(loc("Unable to extract '%1': %2",
                                $self->archive, $Archive::Tar::error ));
}

#################################
#
# Gunzip code
#
#################################

### gunzip wrapper... goes to either Compress::Zlib or /bin/gzip
### depending on $PREFER_BIN
sub _gunzip {
    my $self = shift;

    my @methods = qw[_gunzip_cz _gunzip_bin];
       @methods = reverse @methods if $PREFER_BIN;

    for my $method (@methods) {
        $self->_extractor($method) && return 1 if $self->$method();
    }

    return $self->_error(loc("Unable to gunzip file '%1'", $self->archive));
}

sub _gunzip_bin {
    my $self = shift;

    ### check for /bin/gzip -- we need it ###
    return $self->_error(loc("No '%1' program found", '/bin/gzip'))
        unless $self->bin_gzip;