CPAN::Inject - Base class for injecting distributions into CPAN sources

  # Create the injector
  my $cpan = CPAN::Inject->new(
      sources => '/root/.cpan/sources',  # Required field
      author  => 'LOCAL',                # The default
      );

  # Add a file to the user
  $cpan->add( file => 'some/random/Perl-Tarball-1.02.tar.gz' );

  # What would have have to use when installing
  # $path = 'LOCAL/Perl-Tarball-1.02.tar.gz';
  my $path = $cpan->install_path( 'some/random/Perl-Tarball-1.02.tar.gz' );

  # Create the injector for the default LOCAL author
  $cpan = CPAN::Inject->new(
      sources => '/root/.cpan/sources',
      );

  # Create the injector for a specific author
  $cpan = CPAN::Inject->new(
      sources => '/root/.cpan/sources',
      author  => 'ADAMK',
      );

  # Add a file to the constructor/default author
  $cpan->add( file => 'any/arbitrary/Perl-Tarball-1.01.tar.gz' );

  # Remove a distribution from the repository
  $cpan->remove( dist => 'LOCAL/Perl-Tarball-1.01.tar.gz' );

  # $path = 'authors/id/L/LO/LOCAL'
  $path = $cpan->author_subpath;

  # $path = '/root/.cpan/sources/authors/id/L/LO/LOCAL'
  $path = $cpan->author_subpath;

  # $path = '/root/.cpan/sources/authors/id/L/LO/LOCAL/Perl-Tarball-1.02.tar.gz'
  $path = $cpan->file_path( 'Perl-Tarball-1.02.tar.gz' );
  $path = $cpan->file_path( '/some/random/place/Perl-Tarball-1.02.tar.gz' );

  # $path = 'LOCAL/Perl-Tarball-1.01.tar.gz';
  $path = $cpan->install_path( 'Perl-Tarball-1.01.tar.gz' );
  $path = $cpan->install_path( '/some/random/place/Perl-Tarball-1.02.tar.gz' );

package CPAN::Inject;

use 5.006;
use strict;
use Params::Util    ();
use File::stat      ();
use File::chmod     ();
use File::Spec      ();
use File::Path      ();
use File::Copy      ();
use File::Basename  ();
use CPAN::Checksums ();

use vars qw{$VERSION $CHECK_OWNER};

BEGIN {
	$VERSION = '1.13';

	# Attempt to determine whether or not we are capable
	# of finding the owner of a directory.
	# Unless someone set it to a hard-coded value before we
	# started to load this module.
	unless ( defined $CHECK_OWNER ) {
		# Take a directory we know should exist...
		my $root = File::Spec->rootdir();
		unless ( -d $root ) {
			die "Cannot determine if CPAN::Inject can operate on this platform";
		}

		# ... find the owner for it...
		my $owner = File::stat::stat($root)->uid;

		# ... and if it works, check again in the future.
		# Unless someone set it already, in which case
		$CHECK_OWNER = defined $owner ? 1 : '';
	}

	# And boolify the value, just to be a little safer
	$CHECK_OWNER = !! $CHECK_OWNER;
}





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

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

	# Check where we are going to write to
	my $sources = $self->sources;
	unless ( Params::Util::_STRING($sources) ) {
		Carp::croak("Did not probide a sources param, or not a string");
	}
	unless ( -d $sources ) {
		# The sources directory may actually exist, but we cannot
		# see it because we do not have execute permissions to the
		# parent directory tree.
		# For example, if it is at /root/.cpan/source and we do not
		# have -x permissions to /root
		my ($v, $d) = File::Spec->splitpath( $sources, 'nofile' );
		my @dirs    = File::Spec->splitdir( $d );

		# Ignore the last directory, since that is what we -d tested
		pop @dirs;

		# Check for the existance and rx status of each parent
		foreach my $i ( 0 .. $#dirs ) {
			my $parent = File::Spec->catpath(
				$v,
				File::Spec->catdir( @dirs[0..$i] ),
				'', # No file (returns just the dir)
				);
			unless ( -d $parent ) {
				Carp::croak("The directory '$sources' does not exist");
			}
			unless ( -r $parent and -x $parent ) {
				# Assume that it does exist, but that we can't see it
				Carp::croak("The sources directory is not owned by the current user");
			}
		}
		Carp::croak("The directory '$sources' does not exist");
	}
	unless ( $< == File::stat::stat($sources)->uid ) {
		Carp::croak("The sources directory is not owned by the current user");
	}

	# Check for a default author name
	$self->{author} = 'LOCAL' unless $self->author;
	unless ( _AUTHOR( $self->author ) ) {
		Carp::croak( "The author name '"
			. $self->author
			. "' is not a valid author string"
		);
	}

	$self;
}

sub from_cpan_config {
	my $class = shift;

	# Load the CPAN module
	require CPAN;

	# Support for different mechanisms depending on the version
	# of CPAN that is in use.
	if ( defined $CPAN::HandleConfig::VERSION ) {
		CPAN::HandleConfig->load;
	} else {
		CPAN::Config->load;
	}

	# Get the sources directory
	my $sources = undef;
	if ( defined $CPAN::Config->{keep_source_where} ) {
		$sources = $CPAN::Config->{keep_source_where};
	} elsif ( defined $CPAN::Config->{cpan_home} ) {
		$sources = File::Spec->catdir( $CPAN::Config->{cpan_home}, 'sources' );
	} else {
		Carp::croak("Failed to find sources directory in CPAN::Config");
	}

	# Hand off to the main constructor
	return $class->new(
		sources => $sources,
		@_,
		);
}

sub sources {
	$_[0]->{sources};
}

sub author {
	$_[0]->{author};
}





#####################################################################
# Main methods

sub add {
	my $self   = shift;
	my %params = @_;

	# Check the file source path
	my $from_file = $params{file};
	unless ( $from_file and -f $from_file and -r $from_file ) {
		Carp::croak("Did not provide a file name, or does not exist");
	}

	# Get the file name
	my $name = File::Basename::fileparse($from_file)
		or die "Failed to get filename";

	# Find the location to copy it to
	my $to_file = $self->file_path($name);
	my $to_dir  = File::Basename::dirname($to_file);

	# Make the path for the file
	SCOPE: {
		local $@;
		eval {
			File::Path::mkpath($to_dir);
		};
		if ( my $e = $@ ) {
			Carp::croak("Failed to create $to_dir: $e");
		}
	}

	# Copy the file to the directory, and ensure writable
	File::Copy::copy( $from_file => $to_file )
		or Carp::croak("Failed to copy $from_file to $to_file");
	chmod( 0644, $to_file )
		or Carp::croak("Failed to correct permissions for $to_file");

	# Update the checksums file, and ensure writable
	SCOPE: {
		local $@;
		eval {
			CPAN::Checksums::updatedir($to_dir);
		};
		if ( my $e = $@ ) {
			Carp::croak("Failed to update CHECKSUMS after insertion: $e");
		}
	}
	chmod( 0644, File::Spec->catfile( $to_dir, 'CHECKSUMS' ) )
		or Carp::croak("Failed to correct permissions for CHECKSUMS");

	# Return the install_path as a convenience
	$self->install_path($name);
}

sub remove {
	my $self   = shift;
	my %params = @_;

	# Get the file name
	my $name = File::Basename::fileparse($params{dist})
		or die "Failed to get filename";

	my $file_path = $self->file_path($name);

	# Remove the file from CPAN.
	unlink $file_path while -e $file_path;

	# Update the checksums file
	my $to_file = $self->file_path($name);
	my $to_dir  = File::Basename::dirname($to_file);
	SCOPE: {
		local $@;
		eval {
			CPAN::Checksums::updatedir($to_dir);
		};
		if ( my $e = $@ ) {
			Carp::croak("Failed to update CHECKSUMS after removal: $e");
		}
	}

	return 1;
}

sub author_subpath {
	my $author = $_[0]->author;
	File::Spec->catdir(
		'authors', 'id',
		substr( $author, 0, 1 ),
		substr( $author, 0, 2 ), $author,
	);
}

sub author_path {
	File::Spec->catdir( $_[0]->sources, $_[0]->author_subpath, );
}

sub file_path {
	File::Spec->catfile( $_[0]->sources, $_[0]->author_subpath, $_[1], );
}

sub install_path {
	my $self = shift;
	my $file = File::Basename::fileparse(shift)
		or Carp::croak("Failed to get filename");
	join( '/', $self->author, $file );
}





#####################################################################
# Support Functions

sub _AUTHOR {
	( Params::Util::_STRING( $_[0] ) and $_[0] =~ /^[A-Z]{3,}$/ ) ? $_[0] : undef;
}

1;