view release on metacpan or  search on metacpan

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

        ### XXX figure out how to make IPC::Run do this in one call --
        ### currently i don't know how to get output of a command after a pipe
        ### trapped in a scalar. Mailed barries about this 5th of june 2004.

        ### see what command we should run, based on whether
        ### it's a .tgz or .tar

        ### GNU tar can't handled VMS filespecs, but VMSTAR can handle Unix filespecs.
        my $archive = $self->archive;
        $archive = VMS::Filespec::unixify($archive) if ON_VMS;

        ### XXX solaris tar and bsdtar are having different outputs
        ### depending whether you run with -x or -t
        ### compensate for this insanity by running -t first, then -x
        {    my $cmd =
                $self->is_tgz ? [$self->bin_gzip, '-cdf', $archive, '|',
                                 $self->bin_tar, '-tf', '-'] :
                $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|',
                                 $self->bin_tar, '-tf', '-'] :
                $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|',
                                 $self->bin_tar, '-tf', '-'] :
                [$self->bin_tar, @ExtraTarFlags, '-tf', $archive];

            ### run the command
            ### newer versions of 'tar' (1.21 and up) now print record size
            ### to STDERR as well if v OR t is given (used to be both). This
            ### is a 'feature' according to the changelog, so we must now only
            ### inspect STDOUT, otherwise, failures like these occur:
            ### http://www.cpantesters.org/cpan/report/3230366
            my $buffer  = '';
            my @out     = run(  command => $cmd,
                                buffer  => \$buffer,
                                verbose => $DEBUG );

            ### command was unsuccessful
            unless( $out[0] ) {
                return $self->_error(loc(
                                "Error listing contents of archive '%1': %2",
                                $archive, $buffer ));
            }

            ### no buffers available?
            if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
                $self->_error( $self->_no_buffer_files( $archive ) );

            } else {
                ### if we're on solaris we /might/ be using /bin/tar, which has
                ### a weird output format... we might also be using
                ### /usr/local/bin/tar, which is gnu tar, which is perfectly
                ### fine... so we have to do some guessing here =/
                my @files = map { chomp;
                              !ON_SOLARIS ? $_
                                          : (m|^ x \s+  # 'xtract' -- sigh
                                                (.+?),  # the actual file name
                                                \s+ [\d,.]+ \s bytes,
                                                \s+ [\d,.]+ \s tape \s blocks
                                            |x ? $1 : $_);

                        ### only STDOUT, see above. Sometimes, extra whitespace
                        ### is present, so make sure we only pick lines with
                        ### a length
                        } grep { length } map { split $/, $_ } join '', @{$out[3]};

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

        ### now actually extract it ###
        {   my $cmd =
                $self->is_tgz ? [$self->bin_gzip, '-cdf', $archive, '|',
                                 $self->bin_tar, '-xf', '-'] :
                $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|',
                                 $self->bin_tar, '-xf', '-'] :
                $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|',
                                 $self->bin_tar, '-xf', '-'] :
                [$self->bin_tar, @ExtraTarFlags, '-xf', $archive];

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

            ### we might not have them, due to lack of buffers
            if( $self->files ) {
                ### now that we've extracted, figure out where we extracted to
                my $dir = $self->__get_extract_dir( $self->files );

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

        ### we got here, no error happened
        return 1;
    }
}


### use archive::tar to extract ###
sub _untar_at {
    my $self = shift;

    ### Loading Archive::Tar is going to set it to 1, so make it local
    ### within this block, starting with its initial value. Whatever
    ### Achive::Tar does will be undone when we return.
    ###
    ### Also, later, set $Archive::Tar::WARN to $Archive::Extract::WARN
    ### so users don't have to even think about this variable. If they
    ### do, they still get their set value outside of this call.
    local $Archive::Tar::WARN = $Archive::Tar::WARN;

    ### we definitely need Archive::Tar, so load that first
    {   my $use_list = { 'Archive::Tar' => '0.0' };

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

            $self->_error(loc("You do not have '%1' installed - " .