File Coverage

blib/lib/Test/Inline/Script.pm

Criterion	Covered	Total	%
statement	128	134	95.5
branch	39	54	72.2
condition	10	12	83.3
subroutine	27	28	96.4
pod	14	14	100.0
total	218	242	90.0

package Test::Inline::Script;

=pod

=head1 NAME

Test::Inline::Script - Generate the test file for a single source file

=head1 DESCRIPTION

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

=head1 METHODS

=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';

use vars qw{$VERSION @ISA};
BEGIN {
	$VERSION = '2.213';
	@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

=head2 new

  my $File = Test::Inline::Script->new( $class, \@sections, $check_count );

The C constructor takes a class name, set of Section objects and
an optional C flag.

Returns a Test::Inline::Script object on success.
Returns C on error.

=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

=head2 class

Returns the class that the test file will test

=head2 filename

  my $filename = $File->filename;

The C method returns the name of the output file that the tests
should be written to. For example, the class C would have the
filename value C.

=head2 config

  my $config = $File->config;

The C method returns the config object for the file, assuming that
it has one. If more than one are found, the first will be used, and any
additional config sections discarded.

Returns a L object on success, or false if the
file does not contain a config section.

=head2 setup

  my @setup = $File->setup;

The C method returns the setup sections from the file, in the same
order as in the file.

Returns a list of setup L objects, the null
array C<()> if the file does not contain any setup objects.

=head2 sections

  my @sections = $File->sections;

The C method returns all normal sections from the file, in the
same order as in the file. This may not be the order they will be written
to the test file, for that you should see the C method.

Returns a list of L objects, or the null array
C<()> if the file does not contain any non-setup sections.

=cut

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





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

=pod

=head2 sorted

The C method returns all normal sections from the file, in an order
that satisfies any dependencies in the sections.

Returns a reference to an array of L objects,
C<0> if the file does not contain any non-setup sections, or C on
error.

=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

=head2 tests

If the number of tests for all of the sections within the file are known,
then the number of tests for the entire file can also be determined.

The C method determines if the number of tests can be known, and
if so, calculates and returns the number of tests. Returns false if the
number of tests is not known.

=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

=head2 merged_content

The C method generates and returns the merged contents of all
the sections in the file, including the setup sections at the beginning. The
method does not return the entire file, merely the part contained in the
sections. For the full file contents, see the C method.

Returns a string containing the merged section content on success, false
if there is no content, despite the existance of sections ( which would
have been empty ), or C on error.

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

=pod

=head1 SUPPORT

See the main L section.

=head1 AUTHOR

Adam Kennedy [e-mail], L

=head1 COPYRIGHT

Copyright 2004 - 2013 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