File Coverage

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

Criterion	Covered	Total	%
statement	50	51	98.0
branch	9	14	64.2
condition	4	4	100.0
subroutine	13	13	100.0
pod			n/a
total	76	82	92.6

package CPAN::Access::AdHoc::Util;

use 5.008;

use strict;
use warnings;

use base qw{ Exporter };

use LWP::MediaTypes ();

our @EXPORT_OK = qw{
    __attr __cache __expand_distribution_path __guess_media_type
    __load __whinge __wail __weep
};

our %EXPORT_TAGS = (
    all	=> [ @EXPORT_OK ],
    carp => [ qw{ __whinge __wail __weep } ],
);

our $VERSION = '0.000_194';

sub __attr {
    my ( $self ) = @_;
    my $name_space = caller;
    return ( $self->{$name_space} ||= {} );
}

sub __cache {
    my ( $self ) = @_;
    my $name_space = caller;
    return ( $self->{'.cache'}{$name_space} ||= {} );
}

sub __expand_distribution_path {
    my ( $path ) = @_;
    $path =~ m{ \A ( [^/] ) / ( \1 [^/] ) / ( \2 [^/]* ) }smx
	and return $path;
    $path =~ m< \A ( [^/]{2} ) / ( \1 [^/]* ) >smx
	and return join '/', substr( $1, 0, 1 ), $path;
    $path =~ m< \A ( [^/]+ ) >smx
	or __wail( "Invalid distribution path '$path'" );
    return join '/', substr( $1, 0, 1 ),
	substr( $1, 0, 2 ), $path;
}

{

    my %expand_ending = (
	tbz	=> 'tar.bz2',
	tgz	=> 'tar.gz',
    );

    sub __guess_media_type {
	my ( $resp, $path ) = @_;

	if ( defined $path ) {
	    $resp->header( 'Content-Location' => $path );
	} else {
	    defined( $path = $resp->header( 'Content-Location' ) )
		or __wail(
		'No path provided, and none in Content-Location' );
	}

	# LWP::MediaTypes needs help with some paths.
	$path =~ s{ (?<= [.] ) ( [^.]+ ) \z }
	{ $expand_ending{$1} || $1 }smxie;

	LWP::MediaTypes::guess_media_type( $path, $resp );

	return;
    }

}

sub __load {
    my ( @args ) = @_;
    foreach my $module ( @args ) {

	$module =~ m< \A
	    [[:alpha:]_] \w*
	    (?: :: [[:alpha:]_] \w* )* \z
	>smx
	    or __wail( "Malformed module name '$module'" );

	( my $fn = $module ) =~ s{ :: }{/}smxg;
	$fn .= '.pm';
	require $fn;
    }
    return;
}

our @CARP_NOT = qw{
    CPAN::Access::AdHoc
    CPAN::Access::AdHoc::Archive
    CPAN::Access::AdHoc::Archive::Null
    CPAN::Access::AdHoc::Archive::Tar
    CPAN::Access::AdHoc::Archive::Zip
};


sub __whinge {
    my @args = @_;
    require Carp;
    Carp::carp( @args );
    return;
}

sub __wail {
    my @args = @_;
    require Carp;
    Carp::croak( @args );
}

sub __weep {
    my @args = @_;
    require Carp;
    Carp::confess( 'Programming Error - ', @args );
}

1;

__END__