File Coverage

blib/lib/CPAN/Access/AdHoc.pm

Criterion	Covered	Total	%
statement	263	273	96.3
branch	76	108	70.3
condition	11	18	61.1
subroutine	49	49	100.0
pod	10	11	90.9
total	409	459	89.1

package CPAN::Access::AdHoc;

use 5.008;

use strict;
use warnings;

use Config::Tiny ();
use CPAN::Access::AdHoc::Archive;
use CPAN::Access::AdHoc::Util qw{
    :carp __attr __cache __expand_distribution_path __guess_media_type
};
use Digest::SHA ();
use File::HomeDir ();
use File::Spec ();
use IO::File ();
use LWP::UserAgent ();
use LWP::Protocol ();
use Module::Pluggable::Object;
use Safe;
use Scalar::Util qw{ blessed };
use Text::ParseWords ();
use URI ();

our $VERSION = '0.000_18';

# In the following list of attribute names, 'config' must be first
# because it supplies default values for everything else. 'cpan' must be
# after 'default_cpan_source' because 'default_cpan_source' determines
# how the default value of 'cpan' is computed.
my @attributes = qw{
    config __debug http_error_handler default_cpan_source cpan
};

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

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

    $self->__init( \%arg );

    %arg
	and __wail( 'Unknown attribute(s): ', join ', ', sort keys %arg );

    return $self;
}

sub __init {
    my ( $self, $arg ) = @_;

    foreach my $name ( @attributes ) {
	$self->$name( delete $arg->{$name} );
    }

    return $self;
}

sub corpus {
    my ( $self, $cpan_id ) = @_;
    $cpan_id = uc $cpan_id;

    my $re = join '/',
	substr( $cpan_id, 0, 1 ),
	substr( $cpan_id, 0, 2 ),
	$cpan_id;

    $re = qr{ \A \Q$re\E / }smx;
    return ( grep { $_ =~ $re } $self->indexed_distributions() );
}

sub fetch {
    my ( $self, $path ) = @_;

    $path =~ s{ \A / }{}smx;

    my $ua = LWP::UserAgent->new();

    my $url = $self->cpan() . $path;

    my $rslt = $ua->get( $url );

    $rslt->is_success
	or return $self->http_error_handler()->( $self, $path, $rslt );

    __guess_media_type( $rslt, $path );

    $self->_checksum( $rslt );

    my $archive =
	CPAN::Access::AdHoc::Archive->__handle_http_response( $rslt )
	or __wail( sprintf q{Unsupported Content-Type '%s'},
	$rslt->header( 'Content-Type' ) );

    return $archive;
}

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

    my $cache = $self->__cache();
    exists $cache->{author_index}
	and return $cache->{author_index};

    my $author_details = $self->fetch( 'authors/01mailrc.txt.gz' );
    _got_archive( $author_details )
	or return $author_details;
    $author_details = $author_details->get_item_content();

    my $fh = IO::File->new( \$author_details, '<' )
	or __wail( "Unable to open string reference: $!" );

    my %author_index;
    while ( <$fh> ) {
	s/ \s+ \z //smx;
	my ( undef, $cpan_id, $address ) = Text::ParseWords::parse_line(
	    qr{ \s+ }smx, 0, $_ );
	( my $name = $address ) =~ s{ \s+ < (.*) > }{}smx;
	my $mail_addr = $1;
	$author_index{ uc $cpan_id } = {
	    name	=> $name,
	    address	=> $mail_addr,
	};
    }

    return ( $cache->{author_index} = \%author_index );
}

sub fetch_distribution_archive {
    my ( $self, $distribution ) = @_;
    my $path = __expand_distribution_path( $distribution );
    return $self->fetch( "authors/id/$path" );
}

sub fetch_distribution_checksums {
    my ( $self, $distribution ) = @_;

    $distribution =~ m{ \A ( .* / ) ( [^/]* ) \z }smx
	or __wail( "Invalid distribution '$distribution'" );
    my ( $dir, $file ) = ( $1, $2 );

    $file eq 'CHECKSUMS'
	and $file = '';
    my $path = __expand_distribution_path( $dir . 'CHECKSUMS' );
    ( $dir = $path ) =~ s{ [^/]* \z }{}smx;

    my $cache = $self->__cache();

    if ( ! $cache->{checksums}{$dir} ) {
	my $archive = $self->fetch( "authors/id/$path" );
	_got_archive( $archive )
	    or return $archive;
	$cache->{checksums}{$dir} = _eval_string(
	    $archive->get_item_content() );
    }

    $file eq ''
	and return $cache->{checksums}{$dir};
    return $cache->{checksums}{$dir}{$file};
}

# TODO finish implementing error handling. See above, _got_archive().

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

    my $cache = $self->__cache();

    exists $cache->{module_index}
	and return wantarray ?
	    @{ $cache->{module_index} } :
	    $cache->{module_index}[0];

    my ( $meta, %module );

    # The only way this can return undef is if the http_error_handler
    # returns it. We take that as a request to cache an empty index.
    if ( my $packages_details = $self->fetch(
	    'modules/02packages.details.txt.gz' ) ) {
	$packages_details = $packages_details->get_item_content();

	my $fh = IO::File->new( \$packages_details, '<' )
	    or __wail( "Unable to open string reference: $!" );

	$meta = $self->_read_meta( $fh );

	while ( <$fh> ) {
	    chomp;
	    my ( $mod, @info ) = split qr{ \s+ }smx;
##	    'undef' eq $ver
##		and $ver = undef;
	    my ( $pkg, $ver ) = reverse @info;
	    defined $ver or $ver = 'undef';
	    $module{$mod} = {
		distribution	=> $pkg,
		version		=> $ver,
	    };
	}

    } else {
	$meta = {};
    }

    $cache->{module_index} = [ \%module, $meta ];

    return wantarray ? ( \%module, $meta ) : \%module;
}

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

    my $cache = $self->__cache();
    exists $cache->{registered_module_index}
	and return wantarray ?
	    @{ $cache->{registered_module_index} } :
	    $cache->{registered_module_index}[0];

    my $packages_details = $self->fetch(
	'modules/03modlist.data.gz'
    )->get_item_content();

    my ( $meta, $reg );

    {

	my $fh = IO::File->new( \$packages_details, '<' )
	    or __wail( "Unable to open string reference: $!" );

	$meta = $self->_read_meta( $fh );

	local $/ = undef;
	$reg = <$fh>;
    }

    my $hash = _eval_string( "$reg\nCPAN::Modulelist->data();" );

    $cache->{registered_module_index} = [ $hash, $meta ];

    return wantarray ? ( $hash, $meta ) : $hash;
}

sub flush {
    my ( $self ) = @_;
    delete $self->{'.cache'};
    return $self;
}

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

    my $cache = $self->__cache();

    $cache->{indexed_distributions}
	and return @{ $cache->{indexed_distributions} };

    my $inx = $self->fetch_module_index();

    my %pkg;
    foreach my $info ( values %{ $inx } ) {
	$pkg{$info->{distribution}}++;
    }

    return @{ $cache->{indexed_distributions} = [ sort keys %pkg ] };
}

# Set up the accessor/mutators. All mutators interpret undef as being a
# request to restore the default, from the configuration if that exists,
# or from the configured default code.

__PACKAGE__->__create_accessor_mutators( @attributes );

sub _create_accessor_mutator_helper {
    my ( $class, $name, $code ) = @_;
    $class->can( $name )
	and return;
    my $full_name = "${class}::$name";
    no strict qw{ refs };
    *$full_name = $code;
    return;
}

sub __create_accessor_mutators {
    my ( $class, @attrs ) = @_;
    foreach my $name ( @attrs ) {
	$class->can( $name ) and next;
	my $full_name = "${class}::$name";
	$class->_create_accessor_mutator_helper(
	    "__attr__${name}__validate" => sub { return $_[1] } );
	$class->_create_accessor_mutator_helper(
	    "__attr__${name}__post_assignment" => sub { return $_[1] } );
	no strict qw{ refs };
	*$full_name = sub {
	    my ( $self, @arg ) = @_;
	    my $attr = $self->__attr();
	    if ( @arg ) {
		my $value = $arg[0];
		not defined $value
		    and 'config' ne $name
		    and $value = $self->config()->{_}{$name};
		my $code;
		not defined $value
		    and $code = $self->can( "__attr__${name}__default" )
		    and $value = $code->( $self );
		$code = $self->can( "__attr__${name}__validate" )
		    and $value = $code->( $self, $value );
		$attr->{$name} = $value;
		$code = $self->can( "__attr__${name}__post_assignment" )
		    and $code->( $self );
		return $self;
	    } else {
		return $attr->{$name};
	    }
	};
    }
    return;
}

{

    # Compute the config file's name and location.

    ( my $dist = __PACKAGE__ ) =~ s{ :: }{-}smxg;
    my $config_file = $dist . '.ini';
    my $config_dir = File::HomeDir->my_dist_config( $dist );
    my $config_path;
    defined $config_dir
	and $config_path = File::Spec->catfile( $config_dir, $config_file );

    sub __attr__config__default {
	my ( $self ) = @_;
	defined $config_path
	    and -f $config_path
	    and return Config::Tiny->read( $config_path );
	return Config::Tiny->new();
    }
}

sub __attr__config__validate {
    my ( $self, $value ) = @_;

    my $err = "Attribute 'config' must be a file name or a " .
	"Config::Tiny reference";
    if ( ref $value ) {
	eval {
	    $value->isa( 'Config::Tiny' );
	} or __wail( $err );
    } else {
	-f $value
	    or __wail( $err );
	$value = Config::Tiny->read( $value );
    }

    delete $value->{_}{config};
    return $value;
}

# The rationale of the default order is:
# 1) Mini cpan: guaranteed to be local, and since it is non-core,
#    the user had to install it, and can be presumed to be using it.
# 2) CPAN minus: since it is non-core, the user had to install it,
#    and can be presumed to be using it.
# 3) CPAN: It is core, but it needs to be set up to be used, and the
#    wrapper will detect if it has not been set up.
# 4) CPANPLUS: It is core as of 5.10, and works out of the box, so
#    we can not presume that the user actually uses it.
sub __attr__default_cpan_source__default {
    return 'CPAN::Mini,cpanm,CPAN,CPANPLUS';
}

sub DEFAULT_HTTP_ERROR_HANDLER {
    my ( $self, $path, $resp ) = @_;
    my $url = $self->cpan() . $path;
    __wail( "Failed to get $url: ", $resp->status_line() );
}

sub __attr__http_error_handler__default {
    return \&DEFAULT_HTTP_ERROR_HANDLER;
}

sub __attr__http_error_handler__validate {
    my ( $self, $value ) = @_;
    'CODE' eq ref $value
	or __wail(
	q{Attribute 'http_error_handler' must be a code reference}
    );
    return $value;
}

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

    $self->flush();

    return;
}

sub __attr__cpan__validate {
    my ( $self, $value ) = @_;

    $value = "$value";	# Stringify
    $value =~ s{ (?

    my $url = URI->new( $value )
	or _wail( "Bad URL '$value'" );
    $value = $url;

    my $scheme = $value->scheme();
    $value->can( 'authority' )
	and LWP::Protocol::implementor( $scheme )
	or __wail ( "URL scheme $scheme: is unsupported" );

    return $value;
}

# Check the file's checksum if appropriate.
#
# The argument is the HTTP::Response object that contains the data to
# check. This object is expected to have its Content-Location set to the
# path relative to the root of the site.
#
# Files are not checked unless they are in authors/id/, and are not
# named CHECKSUM.

sub _checksum {
    my ( $self, $rslt ) = @_;
    defined( my $path = $rslt->header( 'Content-Location' ) )
	or return;
    $path =~ m{ \A authors/id/ ( [^/] ) / ( \1 [^/] ) / \2 }smx
	or return;
    $path =~ m{ /CHECKSUMS \z }smx
	and return;
    my $cks_path = $path;
    $cks_path =~ s{ \A authors/id/ }{}smx
	or return;
    my $cksum = $self->fetch_distribution_checksums( $cks_path )
	or return;
    $cksum->{sha256}
	or return;
    my $got = Digest::SHA::sha256_hex( $rslt->content() );
    $got eq $cksum->{sha256}
	or __wail( "Checksum failure on $path" );
    return;
}

# Expand the default_cpan_source attribute into a list of class names,
# each implementing one of the listed defaults.

{

    my $search_path = 'CPAN::Access::AdHoc::Default::CPAN';
    my %defaulter = map { (
        $_ => $_,
	substr( $_, length( $search_path ) + 2 ) => $_,
    ) } Module::Pluggable::Object->new(
	search_path	=> $search_path,
	inner	=> 0,
	require	=> 1,
    )->plugins();

    sub __attr__default_cpan_source__validate {
	my ( $self, $value ) = @_;

	ref $value
	    or $value = [ split qr{ \s* , \s* }smx, $value ];

	'ARRAY' eq ref $value
	    or __wail( q{Attribute 'default_cpan_source' takes an array } .
	    q{reference or a comma-delimited string} );
	my @rslt;
	foreach my $source ( @{ $value } ) {
	    defined( my $class = $defaulter{$source} )
		or __wail( "Unknown default_cpan_source '$source'" );
	    push @rslt, $class;
	}
	return \@rslt;
    }

}

# Eval a string in a sandbox, and return the result. This was cribbed
# _very_ heavily from CPAN::Distribution CHECKSUM_check_file().
sub _eval_string {
    my ( $string ) = @_;
    $string =~ s/ \015? \012 /\n/smxg;
    my $sandbox = Safe->new();
    $sandbox->permit_only( ':default' );
    my $rslt = $sandbox->reval( $string );
    $@ and __wail( $@ );
    return $rslt;
}

# Return the argument if it is a CPAN::Access::AdHoc::Archive; otherwise
# just return.

sub _got_archive {
    my ( $rtn ) = @_;
    blessed( $rtn )
	and $rtn->isa( 'CPAN::Access::AdHoc::Archive' )
	and return $rtn;
    return;
}

# Get the repository URL from the first source that actually supplies
# it. The CPAN::Access::AdHoc::Default::CPAN plug-ins are called in the
# order specified in the default_cpan_source attribute, and the first
# source that actually supplies a URL is used. If that source provides a
# file: URL, the first such is returned. Otherwise the first URL is
# returned, whatever its scheme. If no URL can be determined, we die.

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

    my $url;

    my $debug = $self->__debug();

    foreach my $class ( @{ $self->default_cpan_source() } ) {

	my @url_list = $class->get_default()
	    or next;

	foreach ( @url_list ) {
	    m/ \A file: /smx
		or next;
	    $url = $_;
	    last;
	}

	defined $url
	    or $url = $url_list[0];

	$debug
	    and warn "Debug - Default cpan '$url' from $class\n";

	return $url;
    }

    __wail( 'No CPAN URL obtained from ' . $self->default_cpan_source() );
}

# modules/02packages.details.txt.gz and modules/03modlist.data.gz have
# metadata at the top. This metadata is organized as lines of
#     key: value
# with the key left-justified. Lines can be wrapped, with leading
# spaces.

sub _read_meta {
    my ( $self, $fh ) = @_;
    my %meta;
    {
	my ( $name, $value );
	while ( <$fh> ) {
	    chomp;
	    m/ \S /smx or last;
	    if ( s/ \A \s+ //smx ) {
		$meta{$name} .= " $_";
	    } else {
		( $name, $value ) = split qr{ : \s* }smx, $_, 2;
		$meta{$name} = $value;
	    }
	}
    }
    return \%meta;
}


1;

__END__