File Coverage

lib/Test/Assertions.pm

Criterion	Covered	Total	%
statement	149	218	68.3
branch	45	92	48.9
condition	12	26	46.1
subroutine	21	29	72.4
pod	14	20	70.0
total	241	385	62.6

package Test::Assertions;

use strict;
@Test::Assertions::EXPORT = qw(DIED COMPILES EQUAL EQUALS_FILE MATCHES_FILE FILES_EQUAL ASSESS ASSESS_FILE INTERPRET tests READ_FILE WRITE_FILE);
$Test::Assertions::VERSION = sprintf"%d.%03d", q$Revision: 1.54 $ =~ /: (\d+)\.(\d+)/;

#Define constants
#(avoid "use constant" to cut compile-time overhead slightly - it *is* measurable)
BEGIN
{
	*tests = sub () {1};      # constant to export
	*HAVE_ALARM = sub () {1}; # a flag, so that alarm() is never called if it isn't present (e.g. on Windows)
	eval
	{
		my $was = alarm 0;
		alarm $was;
	};
	undef *HAVE_ALARM, *HAVE_ALARM = sub () {0} if($@); #Change the constant!
}

# this is the number of the current test, for automatically
# numbering the output of ASSERT
$Test::Assertions::test_no = 0;
# this is a flag - true if we are imported in a testing mode
$Test::Assertions::test_mode = 0;

sub import
{
	my $pkg = shift;
	my $style = shift;
	my $callpkg = caller(0);
	no strict 'refs';
	foreach my $sym (@Test::Assertions::EXPORT) {
		*{"$callpkg\::$sym"} = \&{"$pkg\::$sym"};
	}

	#Select implementation of ASSERT
	if(!$style) {
		*{"$callpkg\::ASSERT"} = sub {};
	}
	elsif($style eq 'die') {
		*{"$callpkg\::ASSERT"} = \&{"$pkg\::ASSERT_die"};
	}
	elsif($style eq 'warn') {
		*{"$callpkg\::ASSERT"} = \&{"$pkg\::ASSERT_warn"};
	}
	elsif($style eq 'confess') {
		*{"$callpkg\::ASSERT"} = \&{"$pkg\::ASSERT_confess"};
	}
	elsif($style eq 'cluck') {
		*{"$callpkg\::ASSERT"} = \&{"$pkg\::ASSERT_cluck"};
	}
	elsif($style eq 'test' || $style eq 'test/ok') {
		require File::Spec;
		$Test::Assertions::calling_script = File::Spec->rel2abs($0);
		$Test::Assertions::use_ok = $style eq 'test/ok';
		*{"$callpkg\::ASSERT"} = \&{"$pkg\::ASSERT_test"};
		*{"$callpkg\::ok"} = \&{"$pkg\::ASSERT_test"} if($style eq 'test/ok');
		*{"$callpkg\::plan"} = \&{"$pkg\::plan"};
		*{"$callpkg\::ignore"} = \&{"$pkg\::ignore"};
		*{"$callpkg\::only"} = \&{"$pkg\::only"};
		$Test::Assertions::test_mode = 1;
	}
	else {
		croak("Test::Assertions imported with unknown directive: $style");
	}
}

#For compatibility with Test::Simple
sub plan
{
	shift(); #tests
	my $number = shift();
	$number = _count_tests($Test::Assertions::calling_script)
		unless (defined($number) && $number =~ /^\d+$/);
	print "1..$number\n";
	$Test::Assertions::planned_tests = $number;
	return $number;
}

END
{
	# if we're in test mode and plan() has been called, ensure that the right number of tests have been run
	if ($Test::Assertions::test_mode && defined($Test::Assertions::planned_tests)) {
		if ($Test::Assertions::test_no != $Test::Assertions::planned_tests) {
			warn "# Looks like you planned $Test::Assertions::planned_tests tests but actually ran $Test::Assertions::test_no.\n";
		}
	}
}

#Test filtering
sub ignore
{
	%Test::Assertions::ignore = map {$_ => 1} @_;
}

sub only
{
	%Test::Assertions::only = map {$_ => 1} @_;
}


#
# Various styles
#

sub ASSERT_test ($;$)
{
	my ($test,$msg) = @_;
	my ($pkg, $filename, $line, $sub) = caller(0);
	$Test::Assertions::test_no++;
	if($Test::Assertions::ignore{$Test::Assertions::test_no} ||
	   %Test::Assertions::only && !$Test::Assertions::only{$Test::Assertions::test_no})
	{
		print "ok - skipped $Test::Assertions::test_no";
	}
	else
	{
		print ($test?"ok $Test::Assertions::test_no":"not ok $Test::Assertions::test_no at line $line in $filename");
	}
	print " ($msg)" if(defined $msg);
	print "\n";
}

sub ASSERT_die ($;$)
{
	my $test = shift;
	my $msg = shift;
	$msg="($msg)" if(defined $msg);
	my ($pkg, $filename, $line, $sub) = caller(0);
	die("Assertion failure at line $line in $filename $msg\n") unless($test);
}

sub ASSERT_warn ($;$)
{
	my $test = shift;
	my $msg = shift;
	$msg="($msg)" if(defined $msg);
	my ($pkg, $filename, $line, $sub) = caller(0);
	warn("Assertion failure at line $line in $filename $msg\n") unless($test);
}

sub ASSERT_confess ($;$)
{
	my $test = shift;
	my $msg = shift;
	require Carp;
	$msg="($msg)" if(defined $msg);
	my ($pkg, $filename, $line, $sub);
	if (caller(1)) {
		($pkg, $filename, $line, $sub) = caller(1);
	} else {
		($pkg, $filename, $line, $sub) = caller(0);
	}
	Carp::confess("Assertion failure at line $line in $filename $msg\n") unless($test);
}

sub ASSERT_cluck ($;$)
{
	my $test = shift;
	my $msg = shift;
	require Carp;
	$msg="($msg)" if(defined $msg);
	my ($pkg, $filename, $line, $sub);
	if (caller(1)) {
		($pkg, $filename, $line, $sub) = caller(1);
	} else {
		($pkg, $filename, $line, $sub) = caller(0);
	}
	Carp::cluck("Assertion failure at line $line in $filename $msg\n") unless($test);
}

sub DIED
{
	my ($coderef) = @_;
	eval {&$coderef};
	my $error = $@;
	TRACE("DIED: " . $error);
	return $error;
}

sub COMPILES
{
	my ($file, $strict, $strref) = @_;

	my @args = ($^X);
	push @args, '-Mstrict', '-w' if $strict;
	push @args, '-c', $file;
	my $output;
	my $ok = 0;
	if ($strref && ref($strref) eq 'SCALAR') {
		require IO::CaptureOutput;
		($output, $$strref) = IO::CaptureOutput::capture_exec(@args);
		$ok = ($$strref =~ /syntax OK/);
	} else {
		my $command = join ' ', @args;
		$output = `$command 2>&1`;
		$output =~ s/\n$//;
		$ok = ($output =~ /syntax OK/);
	}
	return wantarray? ($ok, $output) : $ok;
}

sub EQUAL
{
	require Test::More;
	my ($lhs, $rhs) = @_;
	return Test::More::eq_array([$lhs],[$rhs]);
}

sub FILES_EQUAL
{
	require File::Compare;
	my ($lhs, $rhs) = @_;
	return File::Compare::compare($lhs,$rhs)==0;
}

sub EQUALS_FILE
{
	my ($lhs, $rhs) = @_;
	return($lhs eq _read_file($rhs));
}

sub MATCHES_FILE
{
	my ($lhs, $rhs) = @_;
	my $regex = _read_file($rhs);
	return($lhs =~ /^$regex$/);
}

sub ASSESS_FILE
{
	my ($file, $verbose, $timeout) = @_;
	$timeout = 60 unless(defined $timeout);
	my @tests;
	local *FH;
	eval
	{
		alarm $timeout if HAVE_ALARM;
		open (*FH, "$file |") or die("unable to execute $file - $!");
		@tests = ;
		close FH;
	};
	alarm 0 if HAVE_ALARM;
	my $rs;
	if($@) {
		$rs = "not ok for $file ($@)\n"
	} elsif ($?) {
		$rs = "not ok for $file (exit code = $?)\n";
	} else {
		$rs = ASSESS(\@tests, $file, $verbose);
	}
	return wantarray? INTERPRET($rs) : $rs;
}

sub ASSESS
{
	my ($tests, $name, $verbose) = @_;
	my $errors = 0;
	my $total = 0;
	my $expected;
	if (${$tests}[0] =~ m/^1\.\.(\d+)$/) {
		$expected = $1;
	}
	else
	{
		$expected = -1;
	}
	foreach(@$tests)
	{
		if(/^not ok/)
		{
			$errors++; $total++;
			if($verbose)
			{
				s/\n?$/ in $name\n/;
				print;
			}
		}
		elsif(/^ok/)
		{
			$total++;
		}
	}

	my $rs;
	if(defined $name) { $name = " for $name"; } else { $name = ''; }
	if($errors)
	{
		$rs = "not ok$name ($errors errors in $total tests)\n";
	}
	elsif($expected != -1 && $total != $expected)
	{
		$rs = "not ok$name (Expected $expected tests, ran $total tests)\n";
	}
	else
	{
		$rs = "ok$name".($verbose?" passed all $total tests ":"")."\n";
	}
	return wantarray? INTERPRET($rs) : $rs;
}

sub INTERPRET
{
	my $rs = shift;
	my ($status, $desc) = ($rs =~ /^((?:not )?ok)(.*)$/);
	$desc =~ s/^\s+//;
	$desc =~ s/^for //; #ok for x => x
	$desc =~ s/^- //; #ok - x => x
	$desc =~ s/^\((.*)\)/$1/; #ok (x) => x
	return ($status eq 'ok' || 0, $desc);
}

sub READ_FILE
{
	my $filename = shift;
	my $contents;
	eval {
		$contents = _read_file($filename);
	};
	return $contents;
}

sub WRITE_FILE
{
	my ($filename, $contents) = @_;
	my $success;
	eval {
		_write_file($filename, $contents);
		$success = 1;
	};
	return $success;
}

# Misc subroutines

sub _count_tests
{
	my $filename = shift;
	my $count = 0;
	local *LI;
	open (LI, $filename) || die ("Unable to open $filename to count tests - $!");
	while()
	{
		s/\#.+//; # ignore commented-out lines
		$count++ if(/\bASSERT[\s\(]/);
		$count++ if($Test::Assertions::use_ok && /\bok[\s\(]/);
	}
	close LI;
	return $count;
}

sub _read_file
{
	my $filename = shift;
	open (FH, $filename) || die("unable to open $filename - $!");
	local $/ = undef;
	my $data = ;
	close FH;
	return $data;
}

sub _write_file
{
	my ($filename, $data) = @_;
	local *FH;
	open(FH, ">$filename") or die("Unable to open $filename - $!");
	binmode FH;
	print FH $data;
	close FH;
}

#Standard debugging stub - intended to be overridden when
#debugging is needed, e.g. by Log::Trace
sub TRACE {}

1;

__END__