CPAN::Cache - Abstract locally-cached logical subset of a CPAN mirror

  my $cache = CPAN::Cache->new(
      remote_uri => 'http://search.cpan.org/CPAN/',
      local_dir  => '/tmp/cpan',
      );

package CPAN::Cache;

use 5.005;
use strict;
use Carp          ();
use File::Spec    ();
use File::Path    ();
use File::HomeDir ();
use URI::ToDisk   ();
use Params::Util  '_INSTANCE';
use LWP::Simple   ();

use vars qw{$VERSION};
BEGIN {
	$VERSION = '0.02';
}





#####################################################################
# Constructor and Accessors

sub new {
	my $class = shift;
	my $self  = bless { @_ }, $class;

	# Apply boolean flags cleanly
	$self->{verbose}  = !! $self->{verbose};
	$self->{readonly} = !! $self->{readonly};

	# More thorough checking for the 
	my $uri  = $self->{remote_uri}
	           || 'http://search.cpan.org/CPAN/';
	my $path = $self->{local_dir}
	           || File::Spec->catdir(
			File::HomeDir->my_data, '.perl', 'CPAN-Cache'
			);

	# Strip superfluous trailing slashes
	$path =~ s/\/+$//;
	$uri  =~ s/\/+$//;

	# Create the mirror_local path if needed
	-e $path or File::Path::mkpath($path);
	-d $path or Carp::croak("mirror_local: Path '$path' is not a directory");
	-w $path or Carp::croak("mirror_local: No write permissions to path '$path'");

	# Create the mirror object and save the updated values
	$self->{_mirror} = URI::ToDisk->new( $path => $uri )
		or Carp::croak("Unexpected error creating HTML::Location object");

	$self;
}

sub remote_uri {
	$_[0]->{_mirror}->URI;
}

sub local_dir {
	$_[0]->{_mirror}->path;
}

# Undocumented until it is usable
sub trace {
	$_[0]->{trace};
}

# Undocumented until it is usable
sub verbose {
	$_[0]->{verbose};
}

# Undocumented until it is usable
sub readonly {
	$_[0]->{readonly};
}





#####################################################################
# Interface Methods

sub file {
	my $self = shift;
	my $path = $self->_path(shift);

	# Split into parts and find the location for it.
	$self->{_mirror}->catfile( split /\//, $path );
}

sub get {
	my $self = shift;
	my $file = $self->file(shift);

	# Check local dir exists
	my $dir = File::Basename::dirname($file->path);
	-d $dir or File::Path::mkpath($dir);

	# Fetch the file from the server
	my $rc = LWP::Simple::getstore( $file->uri, $file->path );
	if ( LWP::Simple::is_success($rc) ) {
		return $file;
	} elsif ( $rc == LWP::Simple::RC_NOT_FOUND ) {
		return undef;
	} else {
		Carp::croak("$rc error retrieving " . $file->uri);
	}
}

sub mirror {
	my $self = shift;
	my $path = $self->_path(shift);
	my $file = $self->file($path);

	# If any only if a path is "stable" and the file already exists,
	# it is guarenteed not to change, and we don't have to do the
	# mirroring operation.
	if ( $self->_static($path) and -f $file->path ) {
		return $file;
	}

	# Check local dir exists
	my $dir = File::Basename::dirname($file->path);
	-d $dir or File::Path::mkpath($dir);

	# Fetch the file from the server
	my $rc = LWP::Simple::mirror( $file->uri => $file->path );
	if ( LWP::Simple::is_success($rc) ) {
		return $file;
	} elsif ( $rc == LWP::Simple::RC_NOT_MODIFIED ) {
		return $file;
	} elsif ( $rc == LWP::Simple::RC_NOT_FOUND ) {
		return '';
	} else {
		Carp::croak("HTTP $rc error mirroring " . $file->uri);
	}
}

sub static {
	my $self = shift;
	my $path = $self->_path(shift);

	# All checksum files will change
	if ( $path =~ m~/CHECKSUMS$~ ) {
		return '';
	}

	# The .readme files can apparently be changed
	if ( $path =~ m~.readme$~ ) {
		return '';
	}

	# The authors directory is otherwise immutable
	if ( $path =~ m~^authors/~ ) {
		return 1;
	}

	# The safe option is to default to false for the rest
	return '';
}





#####################################################################
# Support Methods

# Validate a CPAN file path
sub _path {
	my $self = shift;
	my $path = shift or Carp::croak("No CPAN path provided");

	# Strip any leading slash
	$path =~ s(^\/)();

	$path;
}

1;