view release on metacpan or  search on metacpan

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

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

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

### use /bin/tar to extract ###
sub _untar_bin {
    my $self = shift;

    ### check for /bin/tar ###
    return $self->_error(loc("No '%1' program found", '/bin/tar'))
        unless $self->bin_tar;

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

    return $self->_error(loc("No '%1' program found", '/bin/bunzip2'))
        if $self->is_tbz && !$self->bin_bunzip2;

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

    ### 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', $self->archive, '|',
                             $self->bin_tar, '-tf', '-'] :
            $self->is_tbz ? [$self->bin_bunzip2, '-c', $self->archive, '|',                             
                             $self->bin_tar, '-tf', '-'] :
            [$self->bin_tar, '-tf', $self->archive];

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

        ### no buffers available?
        if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
            $self->_error( $self->_no_buffer_files( $self->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 : $_);

                    } split $/, $buffer;

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

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

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

    ### we definitely need A::T, so load that first
    {   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'));
        }
    }