File Coverage

blib/lib/Archive/Any.pm

Criterion	Covered	Total	%
statement	57	59	96.6
branch	14	18	77.7
condition			n/a
subroutine	12	13	92.3
pod	7	7	100.0
total	90	97	92.7

package Archive::Any;
$Archive::Any::VERSION = '0.0945';
use strict;
use warnings;

use Archive::Any::Plugin;
use File::Spec::Functions qw( rel2abs splitdir );
use File::MMagic;
use MIME::Types qw(by_suffix);

sub new {
    my ( $class, $file, $type ) = @_;

    $file = rel2abs( $file );
    return unless -f $file;

    my %available;

    my @plugins = Archive::Any::Plugin->findsubmod;
    foreach my $plugin ( @plugins ) {
        eval "require $plugin";
        next if $@;

        my @types = $plugin->can_handle();
        foreach my $type ( @types ) {
            next if exists( $available{$type} );
            $available{$type} = $plugin;
        }
    }

    my $mime_type;

    if ( $type ) {

        # The user forced the type.
        ( $mime_type ) = by_suffix( $type );
        unless ( $mime_type ) {
            warn "No mime type found for type '$type'";
            return;
        }
    }
    else {
        # Autodetect the type.
        $mime_type = File::MMagic->new()->checktype_filename( $file );
    }

    my $handler = $available{$mime_type};
    if ( !$handler ) {
        warn "No handler available for type '$mime_type'";
        return;
    }

    return bless {
        file    => $file,
        handler => $handler,
        type    => $mime_type,
    }, $class;
}

sub extract {
    my $self = shift;
    my $dir  = shift;

    return defined( $dir )
        ? $self->{handler}->_extract( $self->{file}, $dir )
        : $self->{handler}->_extract( $self->{file} );
}

sub files {
    my $self = shift;
    return $self->{handler}->files( $self->{file} );
}

sub is_impolite {
    my $self = shift;

    my @files         = $self->files;
    my $first_file    = $files[0];
    my ( $first_dir ) = splitdir( $first_file );

    return grep( !/^\Q$first_dir\E/, @files ) ? 1 : 0;
}

sub is_naughty {
    my ( $self ) = shift;
    return ( grep {m{^(?:/|(?:\./)*\.\./)}} $self->files ) ? 1 : 0;
}

sub mime_type {
    my $self = shift;
    return $self->{type};
}

#
# This is not really here.  You are not seeing this.
#
sub type {
    my $self = shift;
    return $self->{handler}->type();
}

# End of what you are not seeing.

1;

# ABSTRACT: Single interface to deal with file archives.

__END__