File Coverage

blib/lib/Archive/Builder.pm

Criterion	Covered	Total	%
statement	153	163	93.8
branch	52	64	81.2
condition	1	2	50.0
subroutine	37	39	94.8
pod	14	16	87.5
total	257	284	90.4

package Archive::Builder;

# This packages provides a simplified object for a collection of generated
# files, and ways to then distribute the files.

use 5.005;
use strict;
use Scalar::Util          ();
use List::Util       1.15 ();
use File::Spec       0.80 ();
use File::Spec::Unix      ();
use Params::Util     0.22 ('_INSTANCE', '_STRING');
use Class::Inspector 1.12 ();
use IO::String       1.08 ();
use Class::Autouse   1.27 ('File::Flat');

# Load the rest of the classes;
use Archive::Builder::Section    ();
use Archive::Builder::File       ();
use Archive::Builder::Archive    ();
use Archive::Builder::Generators ();

# Version
use vars qw{$VERSION $errstr};
BEGIN {
	$VERSION = '1.16';
	$errstr  = '';
}





#####################################################################
# Main Interface Methods

# Constructor
sub new { bless { sections => {} }, shift }

# Test generate and cache all files.
sub test { foreach ( $_[0]->section_list ) { $_->test or return undef } 1 }

# Save all files to disk
sub save {
	my $self = shift;
	my $base = shift || '.';

	# Check we can write to the location
	unless ( File::Flat->canWrite( $base ) ) {
		return $self->_error( "Insufficient permissions to write to '$base'" );
	}

	# Process each of the sections
	foreach my $Section ( $self->section_list ) {
		my $subdir = File::Spec->catdir( $base, $Section->path );
		unless ( $Section->save( $subdir ) ) {
			return $self->_error( "Failed to save Archive::Builder to '$base'" );
		}
	}

	1;
}

# Explicitly delete Archive.
# Just pass the call down to the sections.
sub delete { foreach ( $_[0]->section_list ) { $_->delete } 1 }

# If any files have been generated, flush the content cache
# so they will be generated again.
# Just pass the call down to the sections.
sub reset { foreach ( $_[0]->section_list ) { $_->reset } 1 }

# Create a new archive for the Builder
sub archive { Archive::Builder::Archive->new( $_[1], $_[0] ) }

# Create a more shorthand set of data, keying path against content ref
sub _archive_content {
	my $self = shift;

	# Get and merge the _archive_content()s for each section
	my %tree = ();
	foreach my $Section ( $self->section_list ) {
		my $subtree = $Section->_archive_content or return undef;
		my $path = $Section->path;
		foreach ( keys %$subtree ) {
			my $full = File::Spec::Unix->catfile( $path, $_ );
			$tree{$full} = $subtree->{$_};
		}
	}

	\%tree;
}

sub _archive_mode {
	my $self = shift;

	# Collect a list of permission modes to apply
	my %tree = ();
	foreach my $Section ( $self->section_list ) {
		my $subtree = $Section->_archive_mode or return undef;
		my $path    = $Section->path;
		foreach ( keys %$subtree ) {
			my $full = File::Spec::Unix->catfile( $path, $_ );
			$tree{$full} = $subtree->{$_};
		}
	}

	\%tree;
}





#########################################################################
# Working with sections

# Add an existing section
sub add_section {
	my $self    = shift;
	my $Section = _INSTANCE(shift, 'Archive::Builder::Section') or return undef;

	# Does a section with the name already exists?
	my $name = $Section->name;
	if ( exists $self->{sections}->{$name} ) {
		return $self->_error( 'A section with that name already exists' );
	}

	# Add the section
	$Archive::Builder::Section::_PARENT{Scalar::Util::refaddr($Section)} = $self;
	$self->{sections}->{$name} = $Section;
}

# Add a new section and return it
sub new_section {
	my $self = shift;

	# Create the section with the arguments
	my $Section = Archive::Builder::Section->new( @_ ) or return undef;
	$self->add_section($Section);
}

# Add a number of new sections
sub new_sections {
	my $self = shift;
	my %sections = (ref $_[0] eq 'HASH') ? %{$_[0]}
		: map { $_ => $_ } @_;

	# Add each of the sections
	foreach my $name ( sort keys %sections ) {
		my $Section = $self->new_section($name) or return undef;
		if ( $sections{$name} ne $name ) {
			$Section->path($sections{$name}) or return undef;
		}
	}

	1;
}

# Get the hash of sections
sub sections { %{$_[0]->{sections}} ? { %{$_[0]->{sections}} } : 0 }

# Get the sections as a list
sub section_list {
	my $sections = $_[0]->{sections};
	map { $sections->{$_} } sort keys %$sections;
}

# Get a section by name
sub section { defined $_[1] ? $_[0]->{sections}->{$_[1]} : undef }

# Remove a section, by name
sub remove_section {
	my $self = shift;
	my $name = defined $_[0] ? shift : return undef;
	my $Section = $self->{sections}->{$name} or return undef;

	# Delete from our sections
	delete $self->{sections}->{$name};

	# Remove the parent link
	delete $Archive::Builder::Section::_PARENT{Scalar::Util::refaddr($Section)};

	1;
}

# Returns the number of files in the Builder, by totalling
# all it's sections
sub file_count {
	List::Util::sum map { $_->file_count } $_[0]->section_list or 0;
}

# Get a hash of files
sub files {
	my $self  = shift;
	my %files = ();
	foreach my $Section ( values %{$self->{sections}} ) {
		foreach my $File ( $Section->file_list ) {
			my $path = File::Spec::Unix->catfile( $Section->path, $File->path );
			$files{$path} = $File;
		}
	}

	\%files;
}





#####################################################################
# Utility methods

sub _check {
	my $either = shift;
	my $type = shift;
	my $string = shift;

	if ( $type eq 'name' ) {
		return '' unless defined $string;
		return $string =~ /^\w{1,31}$/ ? 1 : '';
	}

	if ( $type eq 'relative path' ) {
		# This makes sure a directory isn't bad
		return $either->_relative_path($string);
	}

	if ( $type eq 'generator' ) {
		return $either->_error( 'No generator defined' ) unless defined $string;

		# Look for illegal characters
		unless ( $string =~ /^\w+(::\w+)*$/ ) {
			return $either->_error( 'Invalid function name format' );
		}

		# Is it a valid alias
		$string = "Archive::Builder::Generators::$string" unless $string =~ /::/;

		# All is good if the function is already loaded
		SCOPE: { no strict 'refs';
			return 1 if defined *{"$string"}{CODE};
		}

		# Does the class exist?
		my ($module) = $string =~ m/^(.*)::.*$/;
		unless ( Class::Inspector->installed( $module ) ) {
			return $either->_error( "Package '$module' does not appear to be present" );
		}

		return 1;
	}

	undef;
}

sub _relative_path {
	my $either = shift;
	my $string = _STRING(shift) or return '';

	# Get the canonical version of the path
	my $canon = File::Spec::Unix->canonpath( $string );

	# Does the path contain escaping forward slashes
	return '' if $string =~ /\\/;

	# We allow one specific exception to the upwards rules.
	# That is in the case where we want to put the content from
	# section into the root of the Builder tree.
	return $string if $string eq '.';

	# Does the path contain upwards stuff?
	return '' unless File::Spec::Unix->no_upwards( $string );
	return '' if $string =~ /\.\./;

	# Is the path absolute
	! File::Spec::Unix->file_name_is_absolute( $string );
}

# Error handling
sub errstr { $errstr }
sub _error { $errstr = $_[1]; undef }
sub _clear { $errstr = '' }

1;

__END__