File Coverage

blib/lib/CPAN/Mini/Extract.pm

Criterion	Covered	Total	%
statement	124	219	56.6
branch	19	74	25.6
condition	4	23	17.3
subroutine	25	32	78.1
pod	4	6	66.6
total	176	354	49.7

package CPAN::Mini::Extract;

=pod

=head1 NAME

CPAN::Mini::Extract - Create CPAN::Mini mirrors with the archives extracted

=head1 SYNOPSIS

  # Create a CPAN extractor
  my $cpan = CPAN::Mini::Extract->new(
      remote         => 'http://mirrors.kernel.org/cpan/',
      local          => '/home/adam/.minicpan',
      trace          => 1,
      extract        => '/home/adam/.cpanextracted',
      extract_filter => sub { /\.pm$/ and ! /\b(inc|t)\b/ },
      extract_check  => 1,
  );

  # Run the minicpan process
  my $changes = $cpan->run;

=head1 DESCRIPTION

C provides a base for implementing systems that
download "all" of CPAN, extract the dists and then process the files
within.

It provides the same syncronisation functionality as L except
that it also maintains a parallel directory tree that contains a directory
located at an identical path to each archive file, with a controllable
subset of the files in the archive extracted below.

=head2 How does it work

C starts with a L local mirror, which it
will optionally update before each run. Once the L directory
is current, it will scan both directory trees, extracting any new archives
and removing any extracted archives no longer in the minicpan mirror.

=head1 EXTENDING

This class is relatively straight forward, but may evolve over time.

If you wish to write an extension, please stay in contact with the
maintainer while doing so.

=head1 METHODS

=cut

use 5.006;
use strict;
use Carp                         ();
use File::Basename               ();
use File::Path                   ();
use File::Spec              0.80 ();
use File::Remove            0.34 ();
use List::Util              1.15 ();
use File::HomeDir           0.88 ();
use File::Temp              0.21 ();
use URI                     1.37 ();
use URI::file                    ();
use IO::File                1.14 ();
use IO::Uncompress::Gunzip 2.017 ();
use Archive::Tar            1.22 ();
use Params::Util            1.00 ();
use LWP::Online             0.03 ();
use File::Find::Rule        0.30 ();
use CPAN::Mini          1.111004 ();

use vars qw{$VERSION @ISA};
BEGIN {
	$VERSION = '1.23';
	@ISA     = 'CPAN::Mini';
}





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

=pod

=head2 new

The C constructor is used to create and configure a new CPAN
Processor. It takes a set of named params something like the following.

  # Create a CPAN processor
  my $Object = CPAN::Mini::Extract->new(
      # The normal CPAN::Mini params
      remote         => 'ftp://cpan.pair.com/pub/CPAN/',
      local          => '/home/adam/.minicpan',
      trace          => 1,

      # Additional params
      extract        => '/home/adam/explosion',
      extract_filter => sub { /\.pm$/ and ! /\b(inc|t)\b/ },
      extract_check  => 1,
      );

=over

=item minicpan args

C inherits from L, so all of the arguments
that can be used with L will also work with
C.

Please note that C applies some additional defaults
beyond the normal ones, like turning C on.

=item offline

Although useless with L itself, the C flag will
cause the CPAN synchronisation step to be skipped, and only any
extraction tasks to be done. (False by default)

=item extract

Provides the directory (which must exist and be writable, or be creatable)
that the tarball dists should be extracted to.

=item extract_filter

C allows you to specify a filter controlling which
types of files are extracted from the Archive. Please note that ONLY
normal files are ever considered for extraction from an archive, with
any directories needed created automatically.

Although by default C only extract files of type .pm,
.t and .pl from the archives, you can add a list of additional things you
do not want to be extracted.

The filter should be provided as a subroutine reference. This sub will
be called with $_ set to the path of the file. The subroutine should
return true if the file is to be extracted, or false if not.

  # Extract all .pm files, except those in an include directory
  extract_filter => sub { /\.pm$/ and ! /\binc\b/ },

=item extract_check

The main extraction process is done as each new archive is downloaded,
but occasionally in a process this long-running something may go wrong
and you can end up with archives not extracted.

In addition, sometimes the processing of the extracted archives is
destructive and will result in them being deleted each run.

Once the mirror update has been completed, the C keyword
forces the processor to go back over every tarball in the mirror and
double check that it has a corrosponding extracted directory.

=item extract_force

For cases in which the filter has been changed, the C
boolean flag can be used to forcefully delete and re-extract every
extracted directory.

=back

Returns a new C object, or dies on error.

=cut

sub new {
	my $class = shift;

	# Use the CPAN::Mini settings as defaults, and add any
	# additional explicit params.
	my %config = ( CPAN::Mini->read_config, @_ );

	# Unless provided auto-detect offline mode
	unless ( defined $config{offline} ) {
		$config{offline} = LWP::Online::offline();
	}

	# Fake a remote URI if CPAN::Mini can't handle offline mode
	my %fake = ();
	if ( $config{offline} and $CPAN::Mini::VERSION < 0.570 ) {
		my $tempdir   = File::Temp::tempdir();
		my $tempuri   = URI::file->new( $tempdir )->as_string;
		$fake{remote} = $tempuri;
	}

	# Use a default local path if none provided
	unless ( defined $config{local} ) {
		my $local = File::Spec->catdir(
			File::HomeDir->my_data, 'minicpan',
		);
	}

	# Call our superclass to create the object
	my $self = $class->SUPER::new( %config, %fake );

	# Check the extract param
	$self->{extract} or Carp::croak(
		"Did not provide an 'extract' path"
		);
	if ( -e $self->{extract} ) {
		unless ( -d _ and -w _ ) {
			Carp::croak(
				"The 'extract' path is not a writable directory"
				);
		}
	} else {
		File::Path::mkpath( $self->{extract}, $self->{trace}, $self->{dirmode} )
			or Carp::croak("The 'extract' path could not be created");
	}

	# Set defaults and apply rules
	unless ( defined $self->{extract_check} ) {
		$self->{extract_check} = 1;
	}
	if ( $self->{extract_force} ) {
		$self->{extract_check} = 1;
	}

	# Compile file_filters if needed
	$self->_compile_filter('extract_filter');

	# We'll need a temp directory for expansions
	$self->{tempdir} = File::Temp::tempdir( CLEANUP => 1 );

	$self;
}





#####################################################################
# Main Methods

=pod

=head2 run

The C methods starts the main process, updating the minicpan mirror
and extracted version, and then launching the PPI Processor to process the
files in the source directory.

Returns the number of changes made to the local minicpan and extracted
directories, or dies on error.

=cut

sub run {
	my $self = shift;

	# Prepare to start
	local $| = 1;
	my $changes;
	$self->{added}   = {};
	$self->{cleaned} = {};

	# If we want to force re-expansion,
	# remove all current expansion dirs.
	if ( $self->{extract_force} ) {
		$self->log("Flushing all expansion directories (extract_force enabled)\n");
		my $authors_dir = File::Spec->catfile( $self->{extract}, 'authors' );
		if ( -e $authors_dir ) {
			$self->log("Removing $authors_dir...");
			File::Remove::remove( \1, $authors_dir ) or Carp::croak(
				"Failed to remove previous expansion directory '$authors_dir'"
				);
			$self->log(" removed\n");
		}
	}

	# Update the CPAN::Mini local mirror
	if ( $self->{offline} and $CPAN::Mini::VERSION < 0.570 ) {
		$self->log("Skipping minicpan update (offline mode enabled)\n");
	} else {
		$self->log("Updating minicpan local mirror...\n");
		$self->update_mirror;
	}

	$changes ||= 0;
	if ( $self->{extract_check} or $self->{extract_force} ) {
		# Expansion checking is enabled, and we didn't do a normal
		# forced check, so find the full list of files to check.
		$self->log("Tarball expansion checking enabled\n");
		my @files = File::Find::Rule->new
					    ->name('*.tar.gz')
					    ->file
					    ->relative
					    ->in( $self->{local} );

		# Filter to just those we need to extract
		$self->log("Checking " . scalar(@files) . " tarballs\n");
		@files = grep { ! -d File::Spec->catfile( $self->{extract}, $_ ) } @files;
		if ( @files ) {
			$self->log("Scheduling " . scalar(@files) . " tarballs for expansion\n");
		} else {
			$self->log("No tarballs need to be extracted\n");
		}

		# Expand each of the tarballs
		foreach my $file ( sort @files ) {
			$self->mirror_extract( $file );
			$changes++;
		}
	}

	$self->log("Completed minicpan extraction\n");
	$changes;
}





#####################################################################
# CPAN::Mini Methods

# Track what we have added
sub mirror_file {
	my $self = shift;
	my $file = shift;

	# Do the normal stuff
	my $rv = $self->SUPER::mirror_file($file, @_);

	# Expand the tarball if needed
	unless ( -d File::Spec->catfile( $self->{extract}, $file ) ) {
		$self->{current_file} = $file;
		$self->mirror_extract( $file ) or return undef;
		delete $self->{current_file};
	}

	$self->{added}->{$file} = 1;
	delete $self->{current_file};
	$rv;
}

sub mirror_extract {
	my ($self, $file) = @_;

	# Don't try to extract anything other than normal tarballs for now.
	return 1 unless $file =~ /\.t(ar\.)?gz$/;

	# Extract the new file to the matching directory in
	# the processor source directory.
	my $local_file  = File::Spec->catfile( $self->{local}, $file   );
	my $extract_dir = File::Spec->catfile( $self->{extract}, $file );

	# Do the actual extraction
	$self->_extract_archive( $local_file, $extract_dir );
}

# Also remove any processing directory.
# And track what we have removed.
sub clean_file {
	my $self = shift;
	my $file = shift; # Absolute path

	# Convert to relative path, and clear the expansion directory
	my $relative = File::Spec->abs2rel( $file, $self->{local} );
	$self->clean_extract( $relative );

	# We are doing this in the reverse order to when we created it.
	my $rv = $self->SUPER::clean_file($file, @_);

	$self->{cleaned}->{$file} = 1;
	$rv;
}

# Remove a processing directory
sub clean_extract {
	my ($self, $file) = @_;

	# Remove the source directory, if it exists
	my $source_path = File::Spec->catfile( $self->{extract}, $file );
	if ( -e $source_path ) {
		File::Remove::remove( \1, $source_path ) or Carp::carp(
			"Cannot remove $source_path $!"
			);
	}

	1;
}





#####################################################################
# Support Methods and Error Handling

# Compile a set of filters
sub _compile_filter {
	my $self = shift;
	my $name = shift;

	# Shortcut for "no filters"
	return 1 unless $self->{$name};

	# If the filter is already a code ref, shortcut
	return 1 if Params::Util::_CODELIKE($self->{$name});

	# Allow a single Regexp object for the filter
	if ( Params::Util::_INSTANCE($self->{$name}, 'Regexp') ) {
		$self->{$name} = [ $self->{$name} ];
	}

	# Check for bad cases
	Params::Util::_ARRAY0($self->{$name}) or Carp::croak(
		"$name is not an ARRAY reference"
		);
	unless ( @{$self->{$name}} ) {
		delete $self->{$name};
		return 1;
	}

	# Check we only got Regexp objects
	my @filters = @{$self->{$name}};
	if ( scalar grep { ! Params::Util::_INSTANCE($_, 'Regexp') } @filters ) {
		return $self->_error("$name can only contains Regexp filters");
	}

	# Build the anonymous sub
	$self->{$name} = sub {
		foreach my $regexp ( @filters ) {
			return 1 if $_ =~ $regexp;
		}
		return '';
	};

	1;
}

# Encapsulate the actual extraction mechanism
sub _extract_archive {
	my ($self, $gz, $to) = @_;

	# Do a one-shot separate decompression because for some reason
	# the default on-the-fly decompression is horridly memory
	# innefficientm, allocating and freeing massive blocks of memory
	# for every single block that gets read in.
	my $archive = $self->_extract_gz( $gz );

	# IO::Zlib::tell will cause problems and Archive::Tar
	# tries to use it by default, so invoke it with a
	# file handle to MAKE it do the right thing.
	my $io = IO::File->new( $archive, "r" )
		or die "Failed to open $archive";

	# Some hints to Archive::Tar to make it behave to make it
	# work better on Win32, and to ignore the ownership crap
	# that we don't care about.
	local $Archive::Tar::WARN  = 0;
	local $Archive::Tar::CHOWN = 0;
	local $Archive::Tar::CHMOD = 0;

	# Load the archive
	my $tar = eval {
		Archive::Tar->new( $io );
	};
	if ( $@ or ! $tar ) {
		return $self->_tar_error("Loading of $archive failed");
	}

	# Get the complete list of files
	my @files = eval {
		$tar->list_files( [ 'name', 'size' ] )
	};
	return $self->_tar_error("Loading of $archive failed") if $@;

	# Filter to get just the ones we want
	@files = map { $_->{name} } grep { $_->{size} } @files;
	if ( $self->{extract_filter} ) {
		@files = grep &{$self->{extract_filter}}, @files;
	}

	# Iterate and extract each file
	File::Path::mkpath( $to, $self->{trace}, $self->{dirmode} );
	foreach my $wanted ( sort @files ) {
		# Where to extract to
		my $to_file = File::Spec->catfile( $to, $wanted );
		my $to_dir  = File::Basename::dirname( $to_file );
		File::Path::mkpath( $to_dir, $self->{trace}, $self->{dirmode} );
		$self->log("write $to_file\n");

		my $rv;
		SCOPE: {
			$rv = eval {
				$tar->extract_file( $wanted, $to_file );
			};
		}
		if ( $@ or ! $rv ) {
			# There was an error during the extraction
			$self->_tar_error( " ... failed" );
			if ( -e $to_file ) {
				# Remove any partial file left behind
				File::Remove::remove( $to_file );
			}
			return 1;
		}
	}

	# Clean up
	$tar->clear;
	undef $tar;
	$io->close;
	File::Remove::remove( $archive );

	return 1;
}

# Extract a gz-compressed file to a temp file
my $counter = 0;
sub _extract_gz {
	my $self = shift;
	my $gz   = shift;
	my $tar  = ++$counter . '.tar';
	my $file = File::Spec->catfile(
		$self->{tempdir}, $tar,
	);
	IO::Uncompress::Gunzip::gunzip( $gz => $file )
		or die "Failed to uncompress $gz";
	return $file;
}

sub _tar_error {
	my $self = shift;

	# Get and clean up the message
	my $message = shift;
	if ( ! $message and $self->{current_file} ) {
		$message = "Expansion of $self->{current_file} failed";
	}
	if ( ! $message ) {
		$message = "Expansion of file failed";
	}
	$message .= " (Archive::Tar warning)" if $@ =~ /Archive::Tar warning/;
	$message .= "\n";

	$self->log($message);
}

1;

=pod

=head1 SUPPORT

Bugs should always be submitted via the CPAN bug tracker

L

For other issues, contact the maintainer

=head1 AUTHOR

Adam Kennedy [e-mail]

=head1 SEE ALSO

L

=head1 COPYRIGHT

Funding provided by The Perl Foundation.

Copyright 2005 - 2012 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