File Coverage

blib/lib/archlib.pm

Criterion	Covered	Total	%
statement	37	58	63.7
branch	7	22	31.8
condition			n/a
subroutine	10	11	90.9
pod	0	2	0.0
total	54	93	58.0

package archlib;
use strict;
use warnings;

#use Archive::Tar;
use Carp qw/croak/;
use List::Util qw/first/;

our $VERSION = '0.002';
our @ARCHINC;
our %CONF;
our $HAVE_ZIP = 0;

BEGIN {
    if( eval 'require Archive::Zip; 1' ) {
         Archive::Zip->import(qw/:ERROR_CODES :CONSTANTS/);
         $HAVE_ZIP = 1;
    }
    else {
        # Fake the constants to satisfy the compiler...
        *AZ_OK = sub { croak "Should not see" };
    }
}

# configure 'zip' handler
BEGIN {
    $CONF{zip} = $HAVE_ZIP ? sub {
        my ( $file ) = @_;
        my $it = Archive::Zip->new;
        croak "Could not open archive '$file'"
            unless $it->read( $file ) == AZ_OK;

        return sub {
            my ( $mod ) = @_;
            my $member = $it->memberNamed($mod);
            return unless $member;
            return split /\n/, $it->contents($member);
        };
    } : sub { croak "Install Archive::Zip for zip support" },
}

# Configure 'tar' handler.
BEGIN {
    my @order = $ENV{ARCHLIB_TAR_ORDER}
    ? split( /\s/, $ENV{ARCHLIB_TAR_ORDER} )
    : qw(Archive::Peek::Libarchive Archive::Peek::External Archive::Tar);

    my $tarmod = first { eval "require $_; 1" } @order;

    if ( $tarmod eq 'Archive::Tar' ) {
        $CONF{'tar'} = sub {
            my ( $file ) = @_;
            my $it = $tarmod->new;
            $it->read( $file );

            return sub {
                my ( $mod ) = @_;
                return unless $it->contains_file($mod);
                return split /\n/, $it->get_content($mod);
            };
        }
    }
    else {
        $CONF{'tar'} = sub {
            my ( $file ) = @_;
            my $it = $tarmod->new( filename => $file );

            return sub {
                my ( $mod ) = @_;
                return unless $it->file($mod);
                return split /\n/, $it->file($mod);
            };
        };
    }
}

unshift @INC => sub {
    my ( $sub, $mod ) = @_;

    for my $arch (@ARCHINC) {
        my @data = $arch->( $mod );
        next unless @data;

        return sub {
            return 0 unless @data;
            $_ = shift(@data);
            return 1;
        };
    }
    return;
};

sub import {
    my $class = shift;
    $class->add_archive( $_ ) for @_;
}

sub add_archive {
    my $class = shift;
    my ( $archive ) = @_;
    croak "No such archive '$archive'"
        unless -e $archive;

    my $type = $class->arch_type( $archive );

    push @ARCHINC => $CONF{$type}->( $archive );
}

sub arch_type {
    my $class = shift;
    my ( $archive ) = @_;
    return 'tar' if $archive =~ m/\.tar(\.bz2|\.gz)?$/i;
    return 'zip' if $archive =~ m/\.zip$/;
    croak "Unknown archive type: '$archive'";
}


1;

__END__