File Coverage

blib/lib/CPAN/Inject.pm

Criterion	Covered	Total	%
statement	101	122	82.7
branch	22	48	45.8
condition	3	12	25.0
subroutine	23	23	100.0
pod	10	10	100.0
total	159	215	73.9

package CPAN::Inject;

=pod

=head1 NAME

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

=head1 SYNOPSIS

  # 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' );

=head1 DESCRIPTION

Following the release of L, the L module
was created to add additional distributions into a minicpan mirror.

While it was created for use with a minicpan mirror, similar
functionality can be reused in other situations.

B replicates the basics of this functionality.

Specifically, it takes an arbitrary tarball and adds it to the CPAN
sources directory for a particular author, and then add the new file
to the F file.

It does not reimplement the logic to add files to the indexes.

The initial use this module was created for was to inject tarballs into
the CPAN sources directory for the reserved LOCAL user, so that the can be
installed via the CPAN shell, with automated recursion to CPAN dependencies.

But although the number of functions is limited (current only C exists,
with the others to be added as needed) the implementation is very generic
and sub-classable, so that it can be reused in other situations.

=head1 METHODS

=cut

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.14';

	# 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

=pod

=head2 new

  # 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',
      );

The C constructor takes a set of named params and create a cpan
injection object.

* B - The compulsory C param should be the path to a
directory that is the root of a mirror (or a partial mirror such as a
L or a L).

To retain the permissions and ownership integrity of the sources tree,
you must be the owner of the C directory in order to inject the
distribution tarballs.

* B - The optional C param should be the CPAN id of an
author. By default, the reserved local CPAN id "LOCAL" will be used.

The author provided will be used as a default in all further actions.

Returns a C object, or throws an exception on error.

=cut

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;
}

=pod

=head2 from_cpan_config

The C constructor loads the CPAN.pm configuration file, and
uses the data contained within to specific the sources path for the
object.

This constructor is otherwise the same.

Returns a B object on success, or throws an exception on
error.

=cut

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,
		@_,
		);
}

=pod

=head2 sources

The C accessor returns the path to the root of the directory tree.

=cut

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

=pod

=head2 author

The C accessor returns the CPAN id for the default author which
will be "LOCAL" if you did not provide an alternative param to the the
C constructor.

=cut

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





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

=pod

=head2 add

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

The C method takes a Perl distribution tarball from an arbitrary
path, and adds it to the sources path.

The specific location the tarball is copied to will be in the root
directory for the author provided to the constructor.

Returns the install_path value as a convenience, or throws an exception
on error.

=cut

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);
}

=pod

=head2 remove

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

The C method takes a distribution path and removes it from the
sources path. The file is also removed.

Does not return anything useful and throws an exception on error.

=cut

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;
}

=pod

=head2 author_subpath

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

The C method takes a CPAN author id (or uses the CPAN
author id originally provided to the constructor) and returns the
relative subpath for the AUTHOR within the sources tree.

Returns the subpath as a string.

=cut

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

=pod

=head2 author_path

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

The C method finds the full path for the root directory for
the named author.

Returns the path as a string.

=cut

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

=pod

=head2 file_path

  # $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' );

The C method takes the name of a tarball (either just the name
or a full path) and calculates the location that the file will end up at.

When files are copied into the sources directory, they are always copied
to the top level of the author root.

Returns the path as a string.

=cut

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

=pod

=head2 install_path

  # $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' );

The C method returns the path for the distribution as the
CPAN shell understands it.

Using this path, the CPAN shell can expand it to locate the
distribution, and then can install it.

Returns the path as a string.

=cut

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]{2,}$/ ) ? $_[0] : undef;
}

1;

=pod

=head1 SUPPORT

This module is stored in an Open Repository at the following address.

L

Write access to the repository is made available automatically to any
published CPAN author, and to most other volunteers on request.

If you are able to submit your bug report in the form of new (failing)
unit tests, or can apply your fix directly instead of submitting a patch,
you are B encouraged to do so as the author currently maintains
over 100 modules and it can take some time to deal with non-Critcal bug
reports or patches.

This will guarentee that your issue will be addressed in the next
release of the module.

If you cannot provide a direct test or fix, or don't have time to do so,
then regular bug reports are still accepted and appreciated via the CPAN
bug tracker.

L

For other issues, for commercial enhancement or support, or to have your
write access enabled for the repository, contact the author at the email
address above.

=head1 AUTHOR

Adam Kennedy [e-mail]

=head1 SEE ALSO

L

=head1 COPYRIGHT

Copyright 2006 - 2011 Adam Kennedy.

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.

=cut