File Coverage

blib/lib/CPAN/Access/AdHoc/Archive/Zip.pm

Criterion	Covered	Total	%
statement	80	90	88.8
branch	20	42	47.6
condition	5	15	33.3
subroutine	16	17	94.1
pod	8	8	100.0
total	129	172	75.0

package CPAN::Access::AdHoc::Archive::Zip;

use 5.008;

use strict;
use warnings;

use base qw{ CPAN::Access::AdHoc::Archive };

use Archive::Zip;
use CPAN::Access::AdHoc::Util qw{ :carp __guess_media_type };
use File::Spec::Unix ();
use IO::File ();

our $VERSION = '0.000_194';

{

    my %decode;

    sub new {
	my ( $class, %arg ) = @_;

	my $self = bless {}, ref $class || $class;

	my $archive = Archive::Zip->new();

	$self->archive( $archive );

	if ( defined( my $content = delete $arg{content} ) ) {

	    if ( my $encoding = delete $arg{encoding} ) {
		$decode{$encoding}
		    or __wail( "Unsupported encoding '$encoding'" );
		$content = $decode{$encoding}->( $content );
	    } elsif ( ref $content ) {
		$content = IO::File->new( $content, '<' )
		    or __wail( "Unable to open string reference: $!" );
	    }

	    my $status = $archive->read( $content );
	    $status == Archive::Zip::AZ_OK()
		or __wail( "Zip read error" );

	    ref $content
		or defined $arg{path}
		or $arg{path} = $content;

	}

	$self->mtime( delete $arg{mtime} );
	$self->path( delete $arg{path} );

	return $self;
    }
}

sub base_directory {
    my ( $self ) = @_;

    my @rslt = sort { length $a <=> length $b || $a cmp $b }
	map { $_->fileName() }
	grep { $_->isDirectory() }
	$self->archive()->members();

    if ( ! @rslt ) {
	@rslt = sort { length $a <=> length $b || $a cmp $b }
	map { ( File::Spec::Unix->splitpath( $_->fileName() ) )[1] }
	$self->archive->members();
    }

    my $base = $rslt[0];
    defined $base
	and '' ne $base
	and $base !~ m{ / \z }smx
	and $base .= '/';

    return $base;
}

sub extract {
    my ( $self ) = @_;

    $self->archive()->extractTree();

    return $self;
}

sub get_item_content {
    my ( $self, $file ) = @_;
    $file = $self->base_directory() . $file;
    my $member = $self->archive()->memberNamed( $file )
	or return;
    return scalar $member->contents();
}

sub get_item_mtime {
    my ( $self, $file ) = @_;
    $file = $self->base_directory() . $file;
    my $member = $self->archive()->memberNamed( $file )
	or return;
    return scalar $member->lastModTime();
}

{

    my %handled = map { $_ => 1 } qw{ application/zip };

    sub __handle_http_response {
	my ( $class, $rslt ) = @_;

	$handled{ $rslt->header( 'Content-Type' ) }
	    or return;

	return $class->new(
	    content	=> \( scalar $rslt->content() ),
	    encoding	=> scalar $rslt->header( 'Content-Encoding' ),
	    mtime	=> HTTP::Date::str2time(
		scalar $rslt->header( 'Last-Modified' ) ),
	    path	=> scalar $rslt->header( 'Content-Location' ),
	);
    }
}

sub item_present {
    my ( $self, $name ) = @_;
    $name = $self->base_directory() . $name;
    return $self->archive()->memberNamed( $name ) ? 1 : 0;
}

sub list_contents {
    my ( $self ) = @_;

    my $base = $self->base_directory();
    $base = qr{ \A \Q$base\E }smx;

    my @rslt;
    foreach my $file ( $self->archive()->members() ) {
	$file->isDirectory()
	    and next;
	my $name = $file->fileName();
	$name =~ s/ $base //smx
	    or next;
	push @rslt, $name;
    }

    return @rslt;
}

sub write : method {	## no critic (ProhibitBuiltInHomonyms)
    my ( $self, $fn ) = @_;
    if ( ! defined $fn ) {
	$fn = ( File::Spec->splitpath( $self->path() ) )[2];
    }
    my $resp = HTTP::Response->new();
    __guess_media_type( $resp, $fn );
    my $encoding = $resp->header( 'Content-Encoding' );
    defined $encoding
	or $encoding = '';
    if ( defined $encoding && '' ne $encoding ) {
	__wail( "Encoding $encoding not supported" );
    }
    my $status = $self->archive()->writeToFileNamed( $fn );
    $status == Archive::Zip::AZ_OK()
	or __wail( 'Zip write error' );
    return $self;
}

1;

__END__