File Coverage

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

Criterion	Covered	Total	%
statement	100	105	95.2
branch	21	40	52.5
condition	8	18	44.4
subroutine	21	21	100.0
pod	8	8	100.0
total	158	192	82.2

package CPAN::Access::AdHoc::Archive::Tar;

use 5.008;

use strict;
use warnings;

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

use Archive::Tar ();
use CPAN::Access::AdHoc::Util qw{ :carp __guess_media_type };
use File::Spec::Unix ();
use HTTP::Date ();
use IO::File ();
use IO::Uncompress::Bunzip2 ();
use IO::Uncompress::Gunzip ();

our $VERSION = '0.000_18';

{

    my %decode = (
	gzip	=> sub {
	    my ( $content ) = @_;
	    return IO::Uncompress::Gunzip->new( $content );
	},
	'x-bzip2'	=> sub {
	    my ( $content ) = @_;
	    return IO::Uncompress::Bunzip2->new( $content );
	},
    );

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

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

	my $archive = Archive::Tar->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: $!" );
	    }

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

	    $archive->read( $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 { _construct_name( $_ ) }
	grep { $_->is_dir() }
	$self->archive()->get_files();

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

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

    return $base;
}

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

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

    return $self;
}

sub get_item_content {
    my ( $self, $file ) = @_;
    $file = $self->base_directory() . $file;
    return $self->archive()->get_content( $file );
}

sub get_item_mtime {
    my ( $self, $file ) = @_;
    $file = $self->base_directory() . $file;
    my @files = $self->archive()->get_files( $file );
    @files
	and return $files[0]->mtime();
    return;
}

{

    my %handled = map { $_ => 1 } qw{ application/x-tar };

    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()->contains_file( $name );
}

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

    my @rslt;

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

    foreach my $file ( $self->archive()->get_files() ) {
	$file->is_file()
	    or next;
	my $name = _construct_name( $file );
	$name =~ s/ $base //smx
	    or next;
	push @rslt, $name;
    }

    return @rslt;
}

{
    my %known_encoding = (
	'gzip'		=> Archive::Tar->COMPRESS_GZIP(),
	'x-bzip2'	=> Archive::Tar->COMPRESS_BZIP(),
    );

    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 = '';
	my @args = ( $fn );
	if ( defined $encoding && '' ne $encoding ) {
	    exists $known_encoding{$encoding}
		or __wail( "Encoding $encoding not supported" );
	    push @args, $known_encoding{$encoding};
	}
	$self->archive()->write( @args );
	return $self;
    }
}

sub _construct_name {
    my ( $file ) = @_;
    my $prefix = $file->prefix();
    if ( defined $prefix && '' ne $prefix ) {
	$prefix =~ m{ / \z }smx
	    or $prefix .= '/';
	return $prefix . $file->name();
    } else {
	return $file->name();
    }
}

1;

__END__