view release on metacpan or  search on metacpan

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

            return METHOD_NA;
        }

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

        $fh_to_read = $xz;
    }

    my @files;
    {
        ### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've
        ### localized $Archive::Tar::WARN already.
        $Archive::Tar::WARN = $Archive::Extract::WARN;

        ### only tell it it's compressed if it's a .tgz, as we give it a file
        ### handle if it's a .tbz
        my @read = ( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) );

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

        ### use the iterator if we can. it's a feature of A::T 1.40 and up
        if ( $_ALLOW_TAR_ITER && Archive::Tar->can( 'iter' ) ) {

            my $next;
            unless ( $next = Archive::Tar->iter( @read ) ) {
                return $self->_error(loc(
                            "Unable to read '%1': %2", $self->archive,
                            $Archive::Tar::error));
            }

            while ( my $file = $next->() ) {
                push @files, $file->full_path;

                $file->extract or return $self->_error(loc(
                        "Unable to read '%1': %2",
                        $self->archive,
                        $Archive::Tar::error));
            }

        ### older version, read the archive into memory
        } else {

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

            unless( $tar->read( @read ) ) {
                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 {};
            }

            {   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 ));
            }

            @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
#
#################################

sub _gunzip_bin {
    my $self = shift;

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

    my $fh = FileHandle->new('>'. $self->_gunzip_to) or
        return $self->_error(loc("Could not open '%1' for writing: %2",
                            $self->_gunzip_to, $! ));

    my $cmd = [ $self->bin_gzip, '-cdf', $self->archive ];

    my $buffer;
    unless( scalar run( command => $cmd,
                        verbose => $DEBUG,
                        buffer  => \$buffer )
    ) {
        return $self->_error(loc("Unable to gunzip '%1': %2",
                                    $self->archive, $buffer));