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

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

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

package CPAN::Mini::Extract;

use 5.006;
use strict;
use Carp                   ();
use File::Spec             ();
use File::Basename         ();
use File::Path             ();
use File::Remove           ();
use List::Util             ();
use File::HomeDir          ();
use File::Temp             ();
use URI::file              ();
use IO::File               ();
use IO::Uncompress::Gunzip ();
use Archive::Tar           ();
use Params::Util           ();
use LWP::Online            ();
use File::Find::Rule       ();
use CPAN::Mini             ();

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





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

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

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->trace("Flushing all expansion directories (extract_force enabled)\n");
		my $authors_dir = File::Spec->catfile( $self->{extract}, 'authors' );
		if ( -e $authors_dir ) {
			$self->trace("Removing $authors_dir...");
			File::Remove::remove( \1, $authors_dir ) or Carp::croak(
				"Failed to remove previous expansion directory '$authors_dir'"
				);
			$self->trace(" removed\n");
		}
	}

	# Update the CPAN::Mini local mirror
	if ( $self->{offline} and $CPAN::Mini::VERSION < 0.570 ) {
		$self->trace("Skipping minicpan update (offline mode enabled)\n");
	} else {
		$self->trace("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->trace("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->trace("Checking " . scalar(@files) . " tarballs\n");
		@files = grep { ! -d File::Spec->catfile( $self->{extract}, $_ ) } @files;
		if ( @files ) {
			$self->trace("Scheduling " . scalar(@files) . " tarballs for expansion\n");
		} else {
			$self->trace("No tarballs need to be extracted\n");
		}

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

	$self->trace("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->trace("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->trace( $message );
}

1;