File Coverage

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

Criterion	Covered	Total	%
statement	110	117	94.0
branch	20	38	52.6
condition	6	12	50.0
subroutine	20	20	100.0
pod	8	8	100.0
total	164	195	84.1

package CPAN::Access::AdHoc::Archive::Null;

use 5.008;

use strict;
use warnings;

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

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

our $VERSION = '0.000_194';

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


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

    my $self = bless {}, ref $class || $class;
    my $attr = $self->__attr();

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

    my $mtime = delete $arg{mtime};

    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 ) {
	    local $/ = undef;	# Slurp mode
	    open my $fh, '<', $content
		or __wail( "Unable to open $content: $!" );
	    my @stat = stat $fh;
	    $content = <$fh>;
	    close $fh;
	    @stat
		and $mtime = $stat[9];
	} elsif ( 'SCALAR' eq ref $content ) {
	    $content = ${ $content };
	}

	my ( $base_dir, $file_name );
	if ( $arg{path} ) {
	    ( undef, $base_dir, $file_name ) =
		File::Spec->splitpath( $arg{path} );
	    $base_dir =~ s{ \A authors/id/
		([^/]) / ( \1 [^/] ) / \2 [^/]* / }{}smx;
	    $file_name =~ s/ [.] (?: gz | bz2 ) \z //smx;
	} else {
	    ( $base_dir, $file_name ) = ( '', 'unknown' );
	}

	$attr->{base_dir} = $base_dir;
	$attr->{contents}{$file_name} = {
	    content	=> $content,
	    mtime	=> $mtime,
	};

	$self->archive( undef );

    }

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

    return $self;
}

sub base_directory {
    my ( $self ) = @_;
    my $attr = $self->__attr();

    return $attr->{base_dir};
}

sub extract {
    my ( $self ) = @_;
    my $attr = $self->__attr();

    my @dirs = grep { defined $_ and '' ne $_ } File::Spec->splitdir(
	$self->base_directory() );
    my $where;
    foreach my $dir ( @dirs ) {
	$where = defined $where ? File::Spec->catdir( $where, $dir ) :
	$dir;
	-d $where
	    or mkdir $where
	    or __wail( "Unable to mkdir $where: $!" );
    }

    foreach my $name ( keys %{ $attr->{contents} } ) {
	my $path = File::Spec->catfile( $where, $name );
	my $fh = IO::File->new( $path, '>' )
	    or __wail( "Unable to open $path for output: $!" );
	print { $fh } $attr->{contents}{$name}{content};
	close $fh;
	my $mtime = $attr->{contents}{$name}{mtime};
	utime $mtime, $mtime, $path;
    }

    return $self;
}

sub get_item_content {
    my ( $self, $file ) = @_;
    my $attr = $self->__attr();

    defined $file
	or ( $file ) = keys %{ $attr->{contents} };

    return $attr->{contents}{$file}{content};
}

sub get_item_mtime {
    my ( $self, $file ) = @_;
    my $attr = $self->__attr();

    defined $file
	or ( $file ) = keys %{ $attr->{contents} };

    return $attr->{contents}{$file}{mtime};
}

{

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

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

	my $content_type = $rslt->header( 'Content-Type' );

	$handled{ $content_type }
	    or $content_type =~ m{ \A text/ }smx
	    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, $item ) = @_;
    my $attr = $self->__attr();

    return defined $attr->{contents}{$item};
}

sub list_contents {
    my ( $self ) = @_;
    my $attr = $self->__attr();

    return ( sort keys %{ $attr->{contents} } );
}

{
    my %known_encoding = (
	# The null encoder does a binmode() on its file handle because I
	# believe that is equivalent to what happens with the
	# IO::Compress::* packages - i.e. they compress bytes, not
	# characters.
	''		=> sub {
	    my ( $fn, $content ) = @_;
	    open my $fh, '>', $fn or __wail( "Open $fn failed: $!" );
	    binmode $fh;
	    print { $fh } $content;
	    close $fh;
	    return;
	},
	'gzip'		=> sub {
	    my ( $fn, $content ) = @_;
	    require IO::Compress::Gzip;
	    IO::Compress::Gzip::gzip( \$content, $fn, AutoClose => 1 )
		or __wail("gzip $fn failed: $IO::Compress::Gzip::GzipError"
	    );
	    return;
	},
	'x-bzip2'	=> sub {
	    my ( $fn, $content ) = @_;
	    require IO::Compress::Bzip2;
	    IO::Compress::Bzip2::bzip2( \$content, $fn )
		or __wail("bzip2 $fn failed: $IO::Compress::Bzip2::Bzip2Error"
	    );
	    return;
	},
    );

    sub write : method {	## no critic (ProhibitBuiltInHomonyms)
	my ( $self, $fn ) = @_;
	my $attr = $self->__attr();

	my ( $file ) = keys %{ $attr->{contents} };
	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 $code = $known_encoding{$encoding}
	    or __wail( "Encoding $encoding not supported" );
	$code->( $fn, $attr->{contents}{$file}{content} );
	return $self;
    }
}

1;

__END__