File Coverage

blib/lib/Test/Dynamic.pm

Criterion	Covered	Total	%
statement	168	214	78.5
branch	88	156	56.4
condition	28	37	75.6
subroutine	5	5	100.0
pod	1	1	100.0
total	290	413	70.2

# -*-cperl-*-
#
# Copyright 2006-2007 Greg Sabino Mullane
#
# Test::Dynamic allows somewhat automatic counting of your tests for Test::More
#

package Test::Dynamic;

use 5.008003;
use utf8;
use strict;
use warnings;

our $VERSION = '1.3.3';

sub count_tests {

	## START_SKIP_TESTCOUNTING

	## Test counting notes:
	## The script must have a __DATA__ line
	## Tests are counted up until the "end" of the script: exit, __DATA__, or __END__
	## Simple test commands are counted as a single item: is, pass, ok, etc.
	## Make sure that test subs use parens: pass("xxx") not pass "xxx"
	## We count how many tests each subroutine runs
	## Some lines are conditional on a global flag for a set of tests: foo(); ## TEST_COPY
	## Conditional blocks can be started and stopped, pure line-by-line basis only
	## Example line 10: foo(); ## START_TEST_COPY  line 20: ## STOP_TEST_COPY
	## Can also use ENV variables with START_ENV_FOO and STOP_ENV_FOO
	## Some lines have multipliers: foobar() ## TESTCOUNT * 5
	## Some have both: foobar() ## TEST_COPY TESTCOUNT + 5
	## To skip entire blocks entirely, use ## START_SKIP_TESTCOUNTING, then ## STOP_SKIP_TESTCOUNTING

	my $self = shift;
	my $arg = shift;

	ref $arg eq 'HASH' or die qq{Argument must be a hashref\n};;

	my $fh = $arg->{filehandle} || die "Need a filehandle argument\n";

	my $verbose_count = exists $arg->{verbose} ? $arg->{verbose} : 1;

	my @testwords = qw(is isnt ok cmp pass fail is_deeply isa_ok can_ok like unlike);

	## no critic
	if (exists $arg->{local}) {
		if (ref $arg->{local} eq 'ARRAY') {
			push @testwords, $_ for @{$arg->{local}};
		}
		elsif (ref $arg->{local} eq 'HASH') {
			push @testwords, $_ for keys %{$arg->{local}};
		}
	}
	## use critic
	my $testwords = join '|' => @testwords;
	$testwords = qr{$testwords};

	my @sublist;
	my %substuff;
	my %subcount;
	my %linemod;
	my %lineskip;
	my %testgroup;
	my $firstline = 0;
	my $lastline = 0;
	for my $pass (1..2) {
		seek($fh,0,0);
		if ($arg->{skipuseline}) {
			1 while <$fh> !~ /^use Test::Dynamic/;
		}
		$firstline ||= $.;
		my $line = $firstline;
		my $currentsub = 'MAIN';
		my $atend = 0;
		my $skipcounting = 0;
		my %skipgroup;
	  T: while (<$fh>) {
			$line++;
			chomp;
			if ($skipcounting) {
				if (/^\s*##\s*STOP_SKIP_TESTCOUNTING/o) {
					$skipcounting=0;
					$verbose_count >= 2 and warn "Found STOP_SKIP at line $line\n";
				}
				next T;
			}
			if (/^\s*##\s*START_SKIP_TESTCOUNTING/o) {
				$verbose_count >= 2 and warn "Found START_SKIP at line $line\n";
				$skipcounting=1;
				next T;
			}

			if (/^\s*exit;/) {
				$atend = 1;
				$lastline ||= $line;
				next T;
			}

			last T if /^__DATA__/ or /^__END__/;

			last T if /\#\#\s*TESTSTOP/;

			next T if $lineskip{$line};

			## Special our lines for test groups
			if (/^our \$(TEST_\w+)\s*=\s*(\d+)/) {
				$testgroup{$1} = $2;
			}


			if (/^}[^;]/ and ! /##/ and @sublist) {
				warn qq{May have a non-closed sub at line $line\n};
			}

			## Starting a new subroutine?
			if (/^\s*sub\s+([\w:_]+)/) {
				$currentsub = $1;
				$verbose_count >= 3 and warn "Sub start: $currentsub\n";
				if (!exists $subcount{$currentsub}) {
					$subcount{$currentsub} = 0;
					$substuff{$currentsub} = {};
				}
				push @sublist, $1;
			}

			## Ending a subroutine?
			if (/##\s+end of (\S+)/o) {
				$verbose_count >= 3 and warn "Sub stop: /$1\n";
				pop @sublist;
				$currentsub = $sublist[-1] || 'MAIN';
			}
			## Skip commented-out lines
			elsif (/^\s*#/) {
				$lineskip{$line} = 1;
				next T;
			}

			if (1 == $pass) {

				## Gather test group information
				if (/##.*?((?:START_|STOP_)?(?:NO)?(?:TEST|ENV)_\S+.*)/o) {
					my $extra = $1;
					$verbose_count >= 2 and warn "Test group: $extra at line $line\n";
					while ($extra =~ m{(START_|STOP_)?(NO)?(TEST|ENV)_(\S+)}g) {
						my ($startstop,$reverse,$type,$name) = ($1||'',$2||0,$3,$4);
						my $val;
						if ('TEST' eq $type) {
							$name = "TEST_$name";
							exists $testgroup{$name} or die qq{Unknown test group "$name" at line $line!\n};
							$val = $testgroup{$name};
						}
						else {
							$val = $ENV{$name} || 0;
						}
						if ($reverse) {
							$val = $val ? 0 : 1;
						}
						if ($startstop eq 'START_') {
							$skipgroup{$name} = $val;
						}
						if ($startstop eq 'STOP_') {
							delete $skipgroup{$name};
						}
						if (!$val) {
							$lineskip{$line} = 1;
							next T;
						}
					}
				}

				## Skip this line if we are in an active skip group
				for my $group (keys %skipgroup) {
					if (!$skipgroup{$group}) {
						$lineskip{$line} = 1;
						next T;
					}
				}

				## Gather any modifiers
				if (/##.*TESTCOUNT\s*([\+\*\-\/])\s*(\d+)/o) {
					$linemod{$line} = [$1,$2];
					## Quick test for no-op adjustments
					if (/^\s*;\s*##/o and !$lineskip{$line}) {
						my $testcount = 0;
						my ($y,$z) = @{$linemod{$line}};
						if    ($y eq '*') { $testcount *= $z; }
						elsif ($y eq '-') { $testcount -= $z; }
						elsif ($y eq '/') { $testcount /= $z; }
						else              { $testcount += $z; }
						$subcount{$currentsub} += $testcount;
						delete $linemod{$line};
					}
				}

				## Count up simple test functions and assign them to a sub
				if (/^\s*$testwords\s*\(/o) {
					## Do nothing if in MAIN and the script has ended
					next T if $currentsub eq 'MAIN' and $atend;

					my $testcount = 1;
					if (exists $linemod{$line}) {
						my ($y,$z) = @{$linemod{$line}};
						if    ($y eq '*') { $testcount *= $z; }
						elsif ($y eq '-') { $testcount -= $z; }
						elsif ($y eq '/') { $testcount /= $z; }
						else              { $testcount += $z; }
					}
					$verbose_count >= 2 and warn "Simple count for $currentsub by $testcount\n";
					$subcount{$currentsub} += $testcount;
					$lineskip{$line} = 1;
				}

				next T;
			} ## end first pass

			if (2 == $pass) {
				## At this point, we know the names of our subroutines
				## We count up the dependencies for each sub
				while ($_ =~ /\b([\w:_]+)\s*\(/g) {
					my $sub = $1;
					next if ! exists $subcount{$sub};
					$sub eq $currentsub
						and die qq{Recursive sub "$sub" at $line: perhaps you forgot "## end of $sub"?\n};
					$verbose_count >= 3 and warn "Adding $sub to $currentsub at line $line\n";
					$substuff{$currentsub}{$sub}{$line} = 1;
				}
				next T;
			}
		}
	} ## end two passes

	## Only worry about the ones called by MAIN
	my %subs = (MAIN => 0);

	my %subtrace = (0 => 'MAIN');
	for my $sub (keys %{$substuff{MAIN}}) {
		for my $line (keys %{$substuff{MAIN}{$sub}}) {
			$subtrace{$line} = $sub;
		}
	}

	my %linecount;
	my $loopy=0;
	{
		## Get a final count for each sub
		my $stilltodo = 0;
		$verbose_count >= 3 and warn "==Entering loop\n";
		for my $sub (sort keys %subs) {
			next if $subs{$sub};
			my $oldscore = $subcount{$sub};
			if (keys %{$substuff{$sub}}) {
				$stilltodo++;
				$verbose_count >= 3 and warn "Need final score for $sub (currently $oldscore)\n";
			}
			else {
				$verbose_count >= 3 and warn "Skipping $sub, has no dependencies\n";
			}
			for my $isub (keys %{$substuff{$sub}}) {
				$subs{$isub} = 0 if !exists $subs{$isub};
				## Does this inner have a raw score?
				my $subitems = keys %{$substuff{$isub}};
				$verbose_count >= 3 and warn "  Checking inner sub $isub ($subcount{$isub}) Items=$subitems\n";
				next if $subitems;
				for my $line (sort {$a<=>$b} keys %{$substuff{$sub}{$isub}}) {
					my $basescore = $subcount{$isub};
					$linecount{$line} = $basescore;
					if (exists $linemod{$line}) {
						my ($y,$z) = @{$linemod{$line}};
						if    ($y eq '*') { $basescore *= $z; }
						elsif ($y eq '-') { $basescore -= $z; }
						elsif ($y eq '/') { $basescore /= $z; }
						else              { $basescore += $z; }
					}
					if ($sub ne 'MAIN' or ($line < $lastline)) {
						$subcount{$sub} += $basescore;
						$linecount{$line} = $basescore;
						$verbose_count >= 3 and warn "    Boost count for $sub by $basescore due to line $line\n";
					}
				}
				## Remove from the list
				$verbose_count >= 3 and warn "  Finished with $isub, so removed from list for $sub\n";
				delete $substuff{$sub}{$isub};
			}
			$verbose_count >= 3 and $subcount{$sub} != $oldscore and warn "New final score for $sub: $subcount{$sub}\n";
		} ## end each sub

		if ($loopy++ > 100) {
			die "Too many loops while trying to figure out test counts";
		}
		redo if $stilltodo;
	}

	if ($verbose_count >= 1) {
		my ($maxline,$maxcount,$maxsub,$maxmod,$maxfinal) = (1,1,3,5,1);
		my @niceline;
		for my $line (sort {$a<=>$b} keys %subtrace) {
			my $sub = $subtrace{$line};
			my $mod = exists $linemod{$line} ? " $linemod{$line}[0] $linemod{$line}[1]" : '';
			my $count = exists $linemod{$line} ? $linecount{$line} : '';
			my $final = exists $linemod{$line} ? $linecount{$line} : $subcount{$sub};
			$maxline  = length($line)  if length($line)  > $maxline;
			$maxcount = length($count) if length($count) > $maxcount;
			$maxsub   = length($sub)   if length($sub)   > $maxsub;
			$maxmod   = length($mod)   if length($mod)   > $maxmod;
			$maxfinal = length($final) if length($final) > $maxfinal;
			push @niceline, [$line,$count,$mod,$final,$sub];
		}
		my $total = -$niceline[0]->[3];
		warn "TEST COUNT:\n";
		for (@niceline) {## 20 * 4 = 80
			$total += $_->[3];
			splice @$_,4,0,$total;
			my $msg = sprintf
				"Line %${maxline}d: (%${maxcount}s%-${maxmod}s = %${maxfinal}d) [%${maxfinal}d] %-${maxsub}s\n", @$_;
			warn $msg;
		}
	}

	$verbose_count >= 1 and warn "Total tests: $subcount{MAIN}\n";

	return $subcount{MAIN};

	## STOP_SKIP_TESTCOUNTING

} ## end of count_tests

1;

__END__