—

              
use strict;
use warnings;
package Footprintless::Extract;
$Footprintless::Extract::VERSION = '1.29';
# ABSTRACT: Extracts data from archives
# PODNAME: Footprintless::Extract
#
use Carp;
use Cwd;
use File::Path qw(make_path);
use File::Spec;
use Log::Any;
my $logger = Log::Any->get_logger();
sub new {
    return bless( {}, shift )->_init(@_);
}
sub extract {
    my ( $self, %options ) = @_;
    my $to = $options{to} || getcwd();
    my $current_dir = getcwd();
    eval {
        croak("$to is not a directory") if ( -e $to && !-d $to );
        make_path($to);
        chdir($to);
        if ( $self->{type} eq 'zip' ) {
            _unzip( $self->{archive}, $to );
        }
        if ( $self->{type} eq 'tar' ) {
            _untar( $self->{archive}, $to );
        }
    };
    my $error = $@;
    chdir($current_dir);
    die($error) if ($error);
    return 1;
}
sub _init {
    my ( $self, %options ) = @_;
    croak('archive required') unless ( $options{archive} );
    $self->{archive} = $options{archive};
    my $dot_extension = $options{type} ? ".$options{type}" : $self->{archive};
    if ( $dot_extension =~ /\.zip|\.war|\.jar|\.ear|\.twbx$/ ) {
        $self->{type} = 'zip';
    }
    elsif ( $dot_extension =~ /\.tar|\.tar\.gz|\.tgz$/ ) {
        $self->{type} = 'tar';
    }
    else {
        croak("unknown archive type");
    }
    return $self;
}
sub _untar {
    my ( $archive, $to ) = @_;
    $logger->tracef( 'untar [%s] to [%s]', $archive, $to );
    require Archive::Tar;
    Archive::Tar->new($archive)->extract();
}
sub _unzip {
    my ( $archive, $to ) = @_;
    $logger->tracef( 'unzip [%s] to [%s]', $archive, $to );
    require IO::Uncompress::Unzip;
    my $unzip = IO::Uncompress::Unzip->new($archive)
        || croak("unable to open $archive: $IO::Uncompress::Unzip::UnzipError");
    my $status;
    eval {
        for ( $status = 1; $status > 0; $status = $unzip->nextStream() ) {
            my $header = $unzip->getHeaderInfo();
            my ( undef, $path, $name ) = File::Spec->splitpath( $header->{Name} );
            my $dest_dir = File::Spec->catdir( $to, $path );
            unless ( -d $dest_dir ) {
                make_path($dest_dir) || croak("unable to create dir $dest_dir: $!");
            }
            unless ($name) {
                last if ( $status < 0 );
                next;
            }
            my $dest_file = File::Spec->catfile( $dest_dir, $name );
            my $buffer;
            my $file = IO::File->new( $dest_file, "w" )
                || croak("unable to create file $dest_file: $!");
            while ( ( $status = $unzip->read($buffer) ) > 0 ) {
                $file->write($buffer);
            }
            $file->close();
            my $stored_time = $header->{Time};
            utime( $stored_time, $stored_time, $dest_file )
                || croak("couldn't set utime on $dest_file: $!");
        }
        croak("error processing $archive: $!") if ( $status < 0 );
    };
    my $error = $@;
    $unzip->close();
    die($error) if ($error);
    return;
}
1;
__END__
HideShow 85 lines of Pod
=pod
=head1 NAME
Footprintless::Extract - Extracts data from archives
=head1 VERSION
version 1.29
=head1 DESCRIPTION
Provides a built in library for extracting data from archives.  It 
presents an interface compatible with C<Archive::Extract> for the 
functions used by C<Footprintless>.
=head1 CONSTRUCTORS
=head2 new(archive => $archive, %options)
Constructs a new instance.  Note that C<archive => $archive> is 
I<REQUIRED> in order to provide a interface compatible with 
C<Archive::Extract>.  The available options are:
=over 4
=item type
The type of archive.  The supported types are C<tar>, C<tgz>, and C<zip>.
If not provided, the file extension will be used to determine the type.
=back
=head1 METHODS
=head2 extract(%options)
Returns a I<truthy> value if C<$hostname> is an alias for localhost.
=over 4
=item to
The destination directory to extract into.  If not supplied, C<Cwd::getcwd>
will be used.
=back
=head1 AUTHOR
Lucas Theisen <lucastheisen@pastdev.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2016 by Lucas Theisen.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=head1 SEE ALSO
Please see those modules/websites for more information related to this module.
=over 4
=item *
L<Footprintless|Footprintless>
=item *
L<Archive::Extract|Archive::Extract>
=item *
L<Cwd::getcwd|Cwd::getcwd>
=item *
L<Footprintless|Footprintless>
=back
=cut