File Coverage

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

Criterion	Covered	Total	%
statement	94	104	90.3
branch	24	34	70.5
condition			n/a
subroutine	21	22	95.4
pod	12	12	100.0
total	151	172	87.7

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

use 5.008;

use strict;
use warnings;

use Cwd ();
use CPAN::Access::AdHoc::Util qw{
    __attr __expand_distribution_path __guess_media_type :carp
};
use CPAN::Meta ();
use HTTP::Response ();
use Module::Pluggable::Object;
use URI::file;

our $VERSION = '0.000_194';

# Note that this can be called as a mutator, but the mutator
# functionality is private to the invocant's class.
sub archive {
    my ( $self, @value ) = @_;
    my $attr = $self->__attr();

    if ( @value ) {
	caller eq ref $self
	    or __wail( 'Attribute archive is read-only' );
	$attr->{archive} = $value[0];
	return $self;
    } else {
	return $attr->{archive};
    }
}

sub base_directory {
    __weep( 'The base_directory() method must be overridden' );
}

sub extract {
    __weep( 'The extract() method must be overridden' );
}

sub get_item_content {
    __weep( 'The get_item_content() method must be overridden' );
}

sub get_item_mtime {
    __weep( 'The get_item_mtime() method must be overridden' );
}

{
    my @archivers = Module::Pluggable::Object->new(
	search_path	=> 'CPAN::Access::AdHoc::Archive',
	inner	=> 0,
	require	=> 1,
    )->plugins();

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

	foreach my $archiver ( @archivers ) {
	    my $archive;
	    defined( $archive = $archiver->__handle_http_response( $resp ) )
		and return $archive;
	}

	return;
    }
}

sub item_present {
    __weep( 'The item_present() method must be overridden' );
}

sub list_contents {
    __weep( 'The list_contents() method must be overridden' );
}

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

    foreach my $spec (
	[ load_json_string	=> 'META.json' ],
	[ load_yaml_string	=> 'META.yml' ],
    ) {
	my ( $method, $file ) = @{ $spec };
	$self->item_present( $file )
	    or next;
	my $meta;
	eval {
	    $meta = CPAN::Meta->$method(
		$self->get_item_content( $file ) );
	} or do {
	    __whinge( "CPAN::Meta->$method() failed: $@" );
	    next;
	};
	return $meta;

    }

    return;

}

# Note that this can be called as a mutator, but the mutator
# functionality is private to the invocant's class.
sub mtime {
    my ( $self, @value ) = @_;
    my $attr = $self->__attr();

    if ( @value ) {
	caller eq ref $self
	    or __wail( 'Attribute archive is read-only' );
	$attr->{mtime} = $value[0];
	return $self;
    } else {
	return $attr->{mtime};
    }
}

# Note that this can be called as a mutator, but the mutator
# functionality is private to the invocant's class.
sub path {
    my ( $self, @value ) = @_;
    my $attr = $self->__attr();

    if ( @value ) {
	caller eq ref $self
	    or __wail( 'Attribute path is read-only' );
	$attr->{path} = $value[0];
	return $self;
    } else {
	return $attr->{path};
    }
}

sub wrap_archive {
    my ( $class, @args ) = @_;
    my $opt = 'HASH' eq ref $args[0] ? shift @args : {};
    my ( $fn ) = @args;
    -f $fn
	or __wail( "File $fn not found" );
    my $content;
    {
	local $/ = undef;
	open my $fh, '<', $fn or __wail( "Unable to open $fn: $!" );
	binmode $fh;
	$content = <$fh>;
	close $fh;
    }
    my $path;
    if ( defined $opt->{directory} ) {
	defined $opt->{author}
	    and __wail(
	    q{Specifying both 'author' and 'directory' is ambiguous} );
	$path = $opt->{directory};
	$path =~ s{ (?
	$path .= ( File::Spec->splitpath( $fn ) )[2];
    } elsif ( defined $opt->{author} ) {
	my $author_path = __expand_distribution_path( $opt->{author} );
	$author_path =~ s{ / \z }{}smx;
	$path = join '/', 'authors/id', $author_path,
	    ( File::Spec->splitpath( $fn ) )[2];
    } else {
	my $uri = URI::file->new( Cwd::abs_path( $fn ) );
	$path = $uri->as_string();
	$path =~ s{ \A .* / (?= authors/ | modules/ ) }{}smx
	    or do {
	    my @parts = File::Spec->splitpath( $uri->file() );
	    my @dir = File::Spec->splitdir( $parts[1] );
	    $dir[-1] eq ''
		and pop @dir;
	    my $author_path = __expand_distribution_path( $dir[-1] );
	    $author_path =~ s{ / \z }{}smx;
	    $path = join '/', 'authors/id', $author_path, $parts[2];
	};
    }
    my $resp = HTTP::Response->new( 200, 'OK', undef, $content );
    __guess_media_type( $resp, $path );
    return $class->__handle_http_response( $resp );
}

sub write : method {	## no critic (ProhibitBuiltInHomonyms)
    __weep( 'The write() method must be overridden' );
}

1;

__END__