The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
BBC / Test-Assertions-1.054 / t / Test-Assertions.t 
#!/usr/local/bin/perl

#
# Unit test for Test::Assertions
# $Id: Test-Assertions.t,v 1.21 2006/01/20 12:22:12 tims Exp $
#
# Options:
# -s : save output files
#

use strict;
use lib qw(./lib ../lib);

use Test::Assertions qw(test);
use Getopt::Std;
use vars qw($opt_s);

#Options
getopts("s");

#Test data
my $lhs = {0=>1, b=>2, c=>3};
my $rhs = {};
$rhs->{c}=3;
$rhs->{b}=2;
$rhs->{0}=1;

#Files generated by this test
my $file1 = 'Test-Assertions.1';
my $file2 = 'Test-Assertions.2';
my $file3 = 'Test-Assertions_child_1.pl';

#Ensure any preserved output files are cleaned away
unlink($file1, $file2, $file3);
die("Unable to clean up output files") if(-e $file1 || -e $file2 || -e $file3);

#Tests
plan tests => 57;
chdir('t') if -d 't';

ASSERT(1, 'compiled');

#
# Test/ok mode
#

import Test::Assertions qw(test/ok);
ok(1);

#
# DIED function
#

ASSERT(DIED(sub  {die()} ), 'die() is detected');

#
# Assess functions
#
ASSERT(ASSESS_FILE("perl fails.pl") =~ /not ok/, 'a failing script is seen as failing');
ASSERT(ASSESS(["not ok"]) =~ /not ok/, 'check that "not ok" is assessed ok');
ASSERT(ASSESS(["ok"]) !~ /not ok/, 'check that "ok" is assessed ok');
ASSERT(ASSESS(["1..3","ok","ok"]) =~ /not ok/, 'check that wrong number of tests is not ok');
my @list = ASSESS(["not ok"], "assess in list context");
ASSERT(!$list[0], $list[1]);
@list = ASSESS(["ok"], "assess in list context"), 
ASSERT($list[0], $list[1]);

#
# Test the EQUAL function
#

ASSERT( EQUAL($lhs, $rhs), 'deep comparisons' );
ASSERT( EQUAL(15, 0x0F), 'scalars' );
ASSERT( EQUAL('hello', 'hello'), 'scalars' );
ASSERT( ! EQUAL('hello', 'world'), 'scalars' );

ASSERT( EQUAL([1, 3, 'e', 't'], [1, 3, 'e', 't']), 'array refs' );
ASSERT( ! EQUAL([1, 3, 'e', 't'], [3, 1, 'e', 't']), 'array refs' );

ASSERT( EQUAL(
{
	hello => 'world',
	234 => 'whoo!!',
	'blah blah' => '',
},
{
	hello => 'world',
	'blah blah' => '',
	234 => 'whoo!!',
}), 'hash refs' );

ASSERT( ! EQUAL(
{
	hello => 'world',
	234 => 'whoo!!',
	'blah blah' => '',
},
{
	hello => 'world',
	234 => 'whoo!!',
}), 'hash refs' );

#
# FILES_EQUAL
#

ASSERT( ! FILES_EQUAL($file1, $file2), 'FILES_EQUAL works on nonexistent files');

WRITE_FILE($file1, '');
WRITE_FILE($file2, '');
ASSERT( -e $file1, 'file written');
ASSERT( -e $file2, 'file written');
ASSERT( FILES_EQUAL($file1, $file2), 'FILES_EQUAL works on zero-sized files');

WRITE_FILE($file1, 'hello');
WRITE_FILE($file2, 'world');
ASSERT( ! FILES_EQUAL($file1, $file2), 'FILES_EQUAL works on nonzero-sized files');

WRITE_FILE($file1, 'hello');
WRITE_FILE($file2, 'hello');
ASSERT( FILES_EQUAL($file1, $file2), 'FILES_EQUAL works on nonzero-sized files');

#
# EQUALS_FILE
#

unlink($file1, $file2);
WRITE_FILE($file1, '');
ASSERT( EQUALS_FILE('', $file1), 'EQUALS_FILE works on zero-sized files');

WRITE_FILE($file1, 'hello');
ASSERT( ! EQUALS_FILE('world', $file1), 'EQUALS_FILE works on nonzero-sized files');

WRITE_FILE($file1, 'hello');
ASSERT( EQUALS_FILE('hello', $file1), 'EQUALS_FILE works on nonzero-sized files');

#
# MATCHES_FILE
#

unlink($file1, $file2);
WRITE_FILE($file1, '');
ASSERT( MATCHES_FILE('', $file1), 'MATCHES_FILE works on zero-sized files');

WRITE_FILE($file1, 'Y\wZ');
ASSERT( ! MATCHES_FILE('LHR', $file1), 'MATCHES_FILE works on nonzero-sized files');

WRITE_FILE($file1, 'Y\wZ');
ASSERT( ! MATCHES_FILE('Callsign YYZ OK', $file1), 'MATCHES_FILE works on nonzero-sized files');
ASSERT( MATCHES_FILE('YYZ', $file1), 'MATCHES_FILE works on nonzero-sized files');

#
# READ_FILE and WRITE_FILE
#

WRITE_FILE($file3, 'use strict;use lib qw(./lib ../lib);
use Test::Assertions qw(test);
plan tests => 2;
ASSERT(1,"OK");ASSERT(1,"OK");');
system("$^X $file3 > $file1 2> $file2");
ASSERT( scalar(READ_FILE($file1) =~ m/1\.\.2.*ok 1.*ok 2/s), "child process writes to $file1");
ASSERT( ! -s $file2, "child process writes nothing to $file2");


WRITE_FILE($file3, 'use strict;use lib qw(./lib ../lib);
use Test::Assertions qw(test);
plan tests => 2;
ASSERT(1);');
system("$^X $file3 > $file1 2> $file2");
ASSERT( scalar(READ_FILE($file1) =~ m/1\.\.2.*ok 1/s), "child process writes to $file1");
ASSERT( scalar(READ_FILE($file2) =~ m/# Looks like.*2.*1/s), "child process writes to $file2");

# plan tests with a chdir
WRITE_FILE($file3, 'use strict;use lib qw(./lib ../lib);
use Test::Assertions qw(test);
chdir("..");
plan tests;
#ASSERT(0)
ASSERT(1);');
system("$^X $file3 > $file1 2> $file2");
ASSERT( scalar(READ_FILE($file1) =~ m/1\.\.1.*ok 1/s), "child process writes to $file1");
ASSERT( length(READ_FILE($file2)) == 0, "child process writes nothing to $file2");
WRITE_FILE($file3, 'use strict;use lib qw(./lib ../lib);
use Test::Assertions qw(warn);
ASSERT(1,"OK");');
system("$^X $file3 > $file1 2> $file2");
ASSERT( ! -s $file1, "child process writes nothing to $file1");
ASSERT( ! -s $file2, "child process writes nothing to $file2");

my $rv = WRITE_FILE($file1, 'hello world 123');
ASSERT($rv == 1, 'file was written');
ASSERT((-e $file1), 'file was written');
ASSERT( WRITE_FILE($file1, 'hello world 123'), 'file was written');

$rv = READ_FILE($file1);
ASSERT($rv eq 'hello world 123', 'file was read OK');
ASSERT( READ_FILE($file1), 'file was read OK' );
ASSERT( READ_FILE($file1) eq 'hello world 123', 'file was read OK' );

$rv = READ_FILE('nonexistent.YYZ');
chomp($@);
ASSERT(! defined $rv, "file was not read: $@");

#
# Different styles
# 

$rv = system("$^X Test-Assertion_style.pl die > $file1 2> $file2");
ASSERT($rv != 0, "child exited not OK");
ASSERT( scalar(READ_FILE($file1) eq "1\.\.1\n"), "child process writes to $file1");
ASSERT( scalar(READ_FILE($file2) =~ m/Assertion failure at line 100 in.*deliberatefail\)\s*$/s), "child process writes to $file2");

$rv = system("$^X Test-Assertion_style.pl warn > $file1 2> $file2");
ASSERT($rv == 0, "child exited OK");
ASSERT( scalar(READ_FILE($file1) eq "1\.\.1\n"), "child process writes to $file1");
ASSERT( scalar(READ_FILE($file2) =~ m/Assertion failure at line 100 in.*deliberatefail\)\s*$/s), "child process writes to $file2");

$rv = system("$^X Test-Assertion_style.pl confess > $file1 2> $file2");
ASSERT($rv != 0, "child exited not OK");
ASSERT( scalar(READ_FILE($file1) eq "1\.\.1\n"), "child process writes to $file1");
ASSERT( scalar(READ_FILE($file2) =~ m/Assertion failure at line 9 in.*deliberatefail.*ASSERT_confess.*called at.*main::to.*called at.*main::go.*called at/s), "child process writes to $file2");

$rv = system("$^X Test-Assertion_style.pl cluck > $file1 2> $file2");
ASSERT($rv == 0, "child exited OK");
ASSERT( scalar(READ_FILE($file1) eq "1\.\.1\n"), "child process writes to $file1");
ASSERT( scalar(READ_FILE($file2) =~ m/Assertion failure at line 9 in.*deliberatefail.*ASSERT_cluck.*called at.*main::to.*called at.*main::go.*called at/s), "child process writes to $file2");

#
# Clean up
#

unlink($file1, $file2, $file3) unless($opt_s);