view release on metacpan or  search on metacpan

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

            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();

    my $ok = 1;
    EXTRACT: {

        ### chdir to the target dir ###
        unless( chdir $dir ) {
            $self->_error(loc("Could not chdir to '%1': %2", $dir, $!));
            $ok = 0; last EXTRACT;
        }

        ### set files to an empty array ref, so there's always an array
        ### ref IN the accessor, to avoid errors like:
        ### Can't use an undefined value as an ARRAY reference at
        ### ../lib/Archive/Extract.pm line 742. (rt #19815)
        $self->files( [] );

        ### find out the dispatch methods needed for this type of
        ### archive. Do a $self->is_XXX to figure out the type, then
        ### get the hashref with bin + pure perl dispatchers.
        my ($map) = map { $Mapping->{$_} } grep { $self->$_ } keys %$Mapping;

        ### add pure perl extractor if allowed & add bin extractor if allowed
        my @methods;
        push @methods, $map->{'pp'}  if $_ALLOW_PURE_PERL;
        push @methods, $map->{'bin'} if $_ALLOW_BIN;

        ### reverse it if we prefer bin extractors
        @methods = reverse @methods if $PREFER_BIN;

        my($na, $fail);
        for my $method (@methods) {
            $self->debug( "# Extracting with ->$method\n" );

            my $rv = $self->$method;

            ### a positive extraction
            if( $rv and $rv ne METHOD_NA ) {
                $self->debug( "# Extraction succeeded\n" );
                $self->_extractor($method);
                last;

            ### method is not available
            } elsif ( $rv and $rv eq METHOD_NA ) {
                $self->debug( "# Extraction method not available\n" );
                $na++;
            } else {
                $self->debug( "# Extraction method failed\n" );
                $fail++;
            }
        }

        ### warn something went wrong if we didn't get an extractor
        unless( $self->_extractor ) {
            my $diag = $fail ? loc("Extract failed due to errors") :
                       $na   ? loc("Extract failed; no extractors available") :
                       '';

            $self->_error($diag);
            $ok = 0;
        }
    }

    ### and chdir back ###
    unless( chdir $cwd ) {
        $self->_error(loc("Could not chdir back to start dir '%1': %2'",
                            $cwd, $!));
    }

    return $ok;
}

=pod

=head1 ACCESSORS

=head2 $ae->error([BOOL])

Returns the last encountered error as string.
Pass it a true value to get the C<Carp::longmess()> output instead.

=head2 $ae->extract_path

This is the directory the archive got extracted to.
See C<extract()> for details.

=head2 $ae->files

This is an array ref holding all the paths from the archive.
See C<extract()> for details.

=head2 $ae->archive

This is the full path to the archive file represented by this
C<Archive::Extract> object.

=head2 $ae->type

This is the type of archive represented by this C<Archive::Extract>
object. See accessors below for an easier way to use this.
See the C<new()> method for details.

=head2 $ae->types

Returns a list of all known C<types> for C<Archive::Extract>'s
C<new> method.

=cut

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

        close $fh;
    }
    else {
        $self->_error(loc("You do not have '%1' or '%2' installed - Please " .
                    "install it as soon as possible.", 'Compress::unLZMA', 'IO::Uncompress::UnLzma'));
        return METHOD_NA;
    }

    ### set what files where extract, and where they went ###
    $self->files( [$self->_gunzip_to] );
    $self->extract_path( File::Spec->rel2abs(cwd()) );

    return 1;
}

#################################
#
# Error code
#
#################################

# For printing binaries that avoids interfering globals
sub _print {
    my $self = shift;
    my $fh = shift;

    local( $\, $", $, ) = ( undef, ' ', '' );
    return print $fh @_;
}

sub _error {
    my $self    = shift;
    my $error   = shift;
    my $lerror  = Carp::longmess($error);

    push @{$self->_error_msg},      $error;
    push @{$self->_error_msg_long}, $lerror;

    ### set $Archive::Extract::WARN to 0 to disable printing
    ### of errors
    if( $WARN ) {
        carp $DEBUG ? $lerror : $error;
    }

    return;
}

sub error {
    my $self = shift;

    ### make sure we have a fallback aref
    my $aref = do {
        shift()
            ? $self->_error_msg_long
            : $self->_error_msg
    } || [];

    return join $/, @$aref;
}

=head2 debug( MESSAGE )

This method outputs MESSAGE to the default filehandle if C<$DEBUG> is
true. It's a small method, but it's here if you'd like to subclass it
so you can so something else with any debugging output.

=cut

### this is really a stub for subclassing
sub debug {
    return unless $DEBUG;

    print $_[1];
}

sub _no_buffer_files {
    my $self = shift;
    my $file = shift or return;
    return loc("No buffer captured, unable to tell ".
               "extracted files or extraction dir for '%1'", $file);
}

sub _no_buffer_content {
    my $self = shift;
    my $file = shift or return;
    return loc("No buffer captured, unable to get content for '%1'", $file);
}
1;

=pod

=head1 HOW IT WORKS

C<Archive::Extract> tries first to determine what type of archive you
are passing it, by inspecting its suffix. It does not do this by using
Mime magic, or something related. See C<CAVEATS> below.

Once it has determined the file type, it knows which extraction methods
it can use on the archive. It will try a perl solution first, then fall
back to a commandline tool if that fails. If that also fails, it will
return false, indicating it was unable to extract the archive.
See the section on C<GLOBAL VARIABLES> to see how to alter this order.

=head1 CAVEATS

=head2 File Extensions

C<Archive::Extract> trusts on the extension of the archive to determine
what type it is, and what extractor methods therefore can be used. If
your archives do not have any of the extensions as described in the
C<new()> method, you will have to specify the type explicitly, or
C<Archive::Extract> will not be able to extract the archive for you.

=head2 Supporting Very Large Files

C<Archive::Extract> can use either pure perl modules or command line
programs under the hood. Some of the pure perl modules (like
C<Archive::Tar> and Compress::unLZMA) take the entire contents of the archive into memory,
which may not be feasible on your system. Consider setting the global
variable C<$Archive::Extract::PREFER_BIN> to C<1>, which will prefer
the use of command line programs and won't consume so much memory.

See the C<GLOBAL VARIABLES> section below for details.

=head2 Bunzip2 support of arbitrary extensions.

Older versions of C</bin/bunzip2> do not support arbitrary file
extensions and insist on a C<.bz2> suffix. Although we do our best
to guard against this, if you experience a bunzip2 error, it may
be related to this. For details, please see the C<have_old_bunzip2>