File Coverage

blib/lib/Test/Inline/Script.pm

Criterion	Covered	Total	%
statement	123	129	95.3
branch	39	54	72.2
condition	10	12	83.3
subroutine	25	26	96.1
pod	14	14	100.0
total	211	235	89.7

package Test::Inline::Script;
# ABSTRACT: Generate the test file for a single source file

#pod =pod
#pod
#pod =head1 DESCRIPTION
#pod
#pod This class is where the heavy lifting happens to actually generating a
#pod test file takes place. Given a source filename, this modules will load
#pod it, parse out the relavent bits, put them into order based on the tags,
#pod and then merge them into a test file.
#pod
#pod =head1 METHODS
#pod
#pod =cut

use strict;
use List::Util                     ();
use Params::Util                   qw{_ARRAY _INSTANCE};
use Algorithm::Dependency::Item    ();
use Algorithm::Dependency::Source  ();
use Algorithm::Dependency::Ordered ();

use overload 'bool' => sub () { 1 },
             '""'   => 'filename';

our $VERSION = '2.214';
our @ISA     = qw{
	Algorithm::Dependency::Source
	Algorithm::Dependency::Item
};

# Special case, for when doing unit tests ONLY.
# Don't throw the missing files warning.
use vars qw{$NO_MISSING_DEPENDENCIES_WARNING};
BEGIN {
	$NO_MISSING_DEPENDENCIES_WARNING = '';
}





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

#pod =pod
#pod
#pod =head2 new
#pod
#pod   my $File = Test::Inline::Script->new( $class, \@sections, $check_count );
#pod
#pod The C constructor takes a class name, set of Section objects and
#pod an optional C flag.
#pod
#pod Returns a Test::Inline::Script object on success.
#pod Returns C on error.
#pod
#pod =cut

sub new {
	my $class       = shift;
	my $_class      = defined $_[0] ? shift : return undef;
	my $Sections    = _ARRAY(shift) or return undef;
	my $check_count = shift || 0;

	# Create the object
	my $self = bless {
		class       => $_class,
		setup       => [ grep {   $_->setup } @$Sections ],
		sections    => [ grep { ! $_->setup } @$Sections ],
		filename    => lc "$_class.t",
		check_count => $check_count,
		# tests     => undef,
		}, $class;
	$self->{filename} =~ s/::/_/g;

	# Verify the uniqueness of the names
	$self->_duplicate_names and return undef;

	# Warn if we have missing dependencies
	my $missing = $self->missing_dependencies;
	if ( $missing ) {
		foreach ( @$missing ) {
			next if $NO_MISSING_DEPENDENCIES_WARNING;
			print "Warning: Missing dependency '$_' in $self->{class}\n";
		}
	}

	# Quickly predetermine if there will be an unknown number
	# of unit tests in the file
	my $unknown = grep { ! defined $_->tests } @$Sections;
	unless ( $unknown or grep { $_->tests } @$Sections ) {
		$unknown = 1;
	}

	# Flag all sections that need count checking in advance
	if ( $check_count ) {
		foreach my $Section ( @$Sections ) {
			next unless defined $Section->tests;
			next unless $unknown or $check_count > 1;

			# Each count check is itself a test, so
			# increment the number of tests for the section
			# when we enable the check flag.
			$Section->{check_count} = 1;
			$Section->{tests}++;
		}
	}

	$self;
}

#pod =pod
#pod
#pod =head2 class
#pod
#pod Returns the class that the test file will test
#pod
#pod =head2 filename
#pod
#pod   my $filename = $File->filename;
#pod
#pod The C method returns the name of the output file that the tests
#pod should be written to. For example, the class C would have the
#pod filename value C.
#pod
#pod =head2 config
#pod
#pod   my $config = $File->config;
#pod
#pod The C method returns the config object for the file, assuming that
#pod it has one. If more than one are found, the first will be used, and any
#pod additional config sections discarded.
#pod
#pod Returns a L object on success, or false if the
#pod file does not contain a config section.
#pod
#pod =head2 setup
#pod
#pod   my @setup = $File->setup;
#pod
#pod The C method returns the setup sections from the file, in the same
#pod order as in the file.
#pod
#pod Returns a list of setup L objects, the null
#pod array C<()> if the file does not contain any setup objects.
#pod
#pod =head2 sections
#pod
#pod   my @sections = $File->sections;
#pod
#pod The C method returns all normal sections from the file, in the
#pod same order as in the file. This may not be the order they will be written
#pod to the test file, for that you should see the C method.
#pod
#pod Returns a list of L objects, or the null array
#pod C<()> if the file does not contain any non-setup sections.
#pod
#pod =cut

sub class    { $_[0]->{class}        }
sub filename { $_[0]->{filename}     }
sub config   { $_[0]->{config} || '' }
sub setup    { @{$_[0]->{setup}}     }
sub sections { @{$_[0]->{sections}}  }





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

#pod =pod
#pod
#pod =head2 sorted
#pod
#pod The C method returns all normal sections from the file, in an order
#pod that satisfies any dependencies in the sections.
#pod
#pod Returns a reference to an array of L objects,
#pod C<0> if the file does not contain any non-setup sections, or C on
#pod error.
#pod
#pod =cut

sub sorted {
	my $self = shift;
	return $self->{sorted} if $self->{sorted};

	# Handle the simple case there there are no dependencies,
	# so we don't have to load the dependency algorithm code.
	unless ( map { $_->depends } $self->sections ) {
		return $self->{sorted} = [ $self->setup, $self->sections ];
	}

	# Create the dependency algorithm object
	my $Algorithm = Algorithm::Dependency::Ordered->new(
		source         => $self,
		ignore_orphans => 1, # Be lenient to non-existant dependencies
		) or return undef;

	# Pull the schedule from the algorithm. If we get an error back, it
	# should be because there is a circular dependency.
	my $schedule = $Algorithm->schedule_all;
	unless ( $schedule ) {
		warn " (Failed to build $self->{class} test schedule) ";
		return undef;
	}

	# Index the sections by name
	my %hash = map { $_->name => $_ } grep { $_->name } $self->sections;

	# Merge together the setup, schedule, and anonymous parts into a
	# single sorted list.
	my @sorted = (
		$self->setup,
		( map { $hash{$_} } @$schedule ),
		( grep { $_->anonymous } $self->sections )
		);

	$self->{sorted} = \@sorted;
}

#pod =pod
#pod
#pod =head2 tests
#pod
#pod If the number of tests for all of the sections within the file are known,
#pod then the number of tests for the entire file can also be determined.
#pod
#pod The C method determines if the number of tests can be known, and
#pod if so, calculates and returns the number of tests. Returns false if the
#pod number of tests is not known.
#pod
#pod =cut

sub tests {
	my $self = shift;
	return $self->{tests} if exists $self->{tests};

	# Add up the tests
	my $total = 0;
	foreach my $Section ( $self->setup, $self->sections ) {
		# Return undef if section has an unknown number of tests
		return undef unless defined $Section->tests;
		$total += $Section->tests;
	}

	# If the total is zero, it's probably screwed, go with "unknown"
	$self->{tests} = $total || undef;
}

#pod =pod
#pod
#pod =head2 merged_content
#pod
#pod The C method generates and returns the merged contents of all
#pod the sections in the file, including the setup sections at the beginning. The
#pod method does not return the entire file, merely the part contained in the
#pod sections. For the full file contents, see the C method.
#pod
#pod Returns a string containing the merged section content on success, false
#pod if there is no content, despite the existance of sections ( which would
#pod have been empty ), or C on error.
#pod
#pod =cut

sub merged_content {
	my $self = shift;
	return $self->{content} if exists $self->{content};

	# Get the sorted Test::Inline::Section objects
	my $sorted = $self->sorted or return undef;

	# Prepare
	$self->{_example_count} = 0;

	# Strip out empty sections
	@$sorted = grep { $_->content =~ /\S/ } @$sorted;

	# Generate wrapped code chunks
	my @content = map { $self->_wrap_content($_) } @$sorted;
	return '' unless @content;

	# Merge to create the core testing code
	$self->{content} = join "\n\n\n", @content;

	# Clean up and return
	delete $self->{_example_count};
	$self->{content};
}

# Take a single generated section of code, and wrap it
# in the standard boilerplate.
sub _wrap_content {
	my $self    = shift;
	my $Section = _INSTANCE(shift, 'Test::Inline::Section') or return undef;
	my $code    = $Section->content;

	# Wrap in compilation test code if an example
	if ( $Section->example ) {
		$self->{_example_count}++;
		$code =~ s/^/    /mg;
		$code = "eval q{\n"
			. "  my \$example = sub {\n"
			. "    local \$^W = 0;\n"
			. $code
			. "  };\n"
			. "};\n"
			. "is(\$@, '', 'Example $self->{_example_count} compiles cleanly');\n";
	}

	# Wrap in scope braces unless it is a setup section
	unless ( $Section->setup ) {
		$code = "{\n"
		      . $code
		      . "}\n";
	}

	# Add the count-checking code if needed
	if ( $Section->{check_count} ) {
		my $increase = $Section->tests - 1;
		my $were     = $increase == 1 ? 'test was' : 'tests were';
		my $section  =
		$code = "\$::__tc = Test::Builder->new->current_test;\n"
		      . $code
		      . "is( Test::Builder->new->current_test - \$::__tc, "
		        . ($increase || '0')
		        . ",\n"
		      . "\t'$increase $were run in the section' );\n";
	}

	# Add the section header
	$code = "# $Section->{begin}\n"
	      . $code;

	# Aaaaaaaand we're done
	$code;
}





#####################################################################
# Implement the Algorithm::Dependency::Source Interface
# This is used for section-level dependency.
# These methods, though public, are undocumented.

# Our implementation of Algorithm::Dependency::Source->load is a no-op
sub load { 1 }

# Pull a single item by name, section in the sections for it
sub item {
	my $self = shift;
	my $name = shift or return undef;
	List::Util::first { $_->name eq $name } $self->sections;
}

# Return, in their original order, all the items ( named sections )
sub items { grep { $_->name } $_[0]->sections }





#####################################################################
# Implement the Algorithm::Dependency::Item Interface
# This is used for class-level dependency.
# These methods, though public, are undocumented.

sub id {
	$_[0]->{class};
}

sub depends {
	my $self = shift;
	my %depends = map { $_ => 1     }
	              map { $_->classes }
	              ($self->setup, $self->sections);
	keys %depends;
}





#####################################################################
# Utility Functions

sub _duplicate_names(@) {
	my $self = shift;
	my %seen = ();
	foreach ( map { $_->name } $self->sections ) {
		next unless $_;
		return 1 if $seen{$_}++;
	}
	undef;
}

1;

__END__