view release on metacpan or  search on metacpan

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

                $ar =~ /.+?\.gz$/i                      ? GZ    :
                $ar =~ /.+?\.tar$/i                     ? TAR   :
                $ar =~ /.+?\.(zip|jar|ear|war|par)$/i   ? ZIP   :
                $ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i     ? TBZ   :
                $ar =~ /.+?\.bz2$/i                     ? BZ2   :
                $ar =~ /.+?\.Z$/                        ? Z     :
                $ar =~ /.+?\.lzma$/                     ? LZMA  :
                $ar =~ /.+?\.(?:txz|tar\.xz)$/i         ? TXZ   :
                $ar =~ /.+?\.xz$/                       ? XZ    :
                '';

        }

        bless $parsed, $class;

        ### don't know what type of file it is
        ### XXX this *has* to be an object call, not a package call
        return $parsed->_error(loc("Cannot determine file type for '%1'",
                                $parsed->{archive} )) unless $parsed->{type};
        return $parsed;
    }
}

=head2 $ae->extract( [to => '/output/path'] )

Extracts the archive represented by the C<Archive::Extract> object to
the path of your choice as specified by the C<to> argument. Defaults to
C<cwd()>.

Since C<.gz> files never hold a directory, but only a single file; if
the C<to> argument is an existing directory, the file is extracted
there, with its C<.gz> suffix stripped.
If the C<to> argument is not an existing directory, the C<to> argument
is understood to be a filename, if the archive type is C<gz>.
In the case that you did not specify a C<to> argument, the output
file will be the name of the archive file, stripped from its C<.gz>
suffix, in the current working directory.

C<extract> will try a pure perl solution first, and then fall back to
commandline tools if they are available. See the C<GLOBAL VARIABLES>
section below on how to alter this behaviour.

It will return true on success, and false on failure.

On success, it will also set the follow attributes in the object:

=over 4

=item $ae->extract_path

This is the directory that the files where extracted to.

=item $ae->files

This is an array ref with the paths of all the files in the archive,
relative to the C<to> argument you specified.
To get the full path to an extracted file, you would use:

    File::Spec->catfile( $to, $ae->files->[0] );

Note that all files from a tar archive will be in unix format, as per
the tar specification.

=back

=cut

sub extract {
    my $self = shift;
    my %hash = @_;

    ### reset error messages
    $self->_error_msg( [] );
    $self->_error_msg_long( [] );

    my $to;
    my $tmpl = {
        to  => { default => '.', store => \$to }
    };

    check( $tmpl, \%hash ) or return;

    ### so 'to' could be a file or a dir, depending on whether it's a .gz
    ### file, or basically anything else.
    ### so, check that, then act accordingly.
    ### set an accessor specifically so _gunzip can know what file to extract
    ### to.
    my $dir;
    {   ### a foo.gz file
        if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma or $self->is_xz ) {

            my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma|xz)$//i;

            ### to is a dir?
            if ( -d $to ) {
                $dir = $to;
                $self->_gunzip_to( basename($cp) );

            ### then it's a filename
            } else {
                $dir = dirname($to);
                $self->_gunzip_to( basename($to) );
            }

        ### not a foo.gz file
        } else {
            $dir = $to;
        }
    }

    ### make the dir if it doesn't exist ###
    unless( -d $dir ) {
        eval { mkpath( $dir ) };

        return $self->_error(loc("Could not create path '%1': %2", $dir, $@))
            if $@;
    }

    ### get the current dir, to restore later ###
    my $cwd = cwd();

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

    );

    ### no output
    return unless $buffer;

    my ($version) = $buffer =~ /version \s+ (\d+)/ix;

    return 1 if $version < 1;
    return;
}

#################################
#
# Untar code
#
#################################

### annoying issue with (gnu) tar on win32, as illustrated by this
### bug: https://rt.cpan.org/Ticket/Display.html?id=40138
### which shows that (gnu) tar will interpret a file name with a :
### in it as a remote file name, so C:\tmp\foo.txt is interpreted
### as a remote shell, and the extract fails.
{   my @ExtraTarFlags;
    if( ON_WIN32 and my $cmd = __PACKAGE__->bin_tar ) {

        ### if this is gnu tar we are running, we need to use --force-local
        push @ExtraTarFlags, '--force-local' if `$cmd --version` =~ /gnu tar/i;
    }


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

        ### check for /bin/tar ###
        ### check for /bin/gzip if we need it ###
        ### if any of the binaries are not available, return NA
        {   my $diag =  not $self->bin_tar ?
                            loc("No '%1' program found", '/bin/tar') :
                        $self->is_tgz && !$self->bin_gzip ?
                            loc("No '%1' program found", '/bin/gzip') :
                        $self->is_tbz && !$self->bin_bunzip2 ?
                            loc("No '%1' program found", '/bin/bunzip2') :
                        $self->is_txz && !$self->bin_unxz ?
                            loc("No '%1' program found", '/bin/unxz') :
                        '';

            if( $diag ) {
                $self->_error( $diag );
                return METHOD_NA;
            }
        }

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