use strict;

package Test;

use Test::Harness 1.1601 ();

use Carp;

our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $ntest, $TestLevel); #public-ish

our($TESTOUT, $ONFAIL, %todo, %history, $planned, @FAILDETAIL); #private-ish

$VERSION = '1.15';

require Exporter;

@ISA=('Exporter');

@EXPORT=qw(&plan &ok &skip);

@EXPORT_OK=qw($ntest $TESTOUT);

$TestLevel = 0; # how many extra stack frames to skip

$|=1;

$ntest=1;

$TESTOUT = *STDOUT{IO};

$ENV{REGRESSION_TEST} = $0;

sub plan {

croak "Test::plan(%args): odd number of arguments" if @_ & 1;

croak "Test::plan(): should not be called more than once" if $planned;

my $max=0;

for (my $x=0; $x < @_; $x+=2) {

my ($k,$v) = @_[$x,$x+1];

if ($k =~ /^test(s)?$/) { $max = $v; }

elsif ($k eq 'todo' or

$k eq 'failok') { for (@$v) { $todo{$_}=1; }; }

elsif ($k eq 'onfail') {

ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";

$ONFAIL = $v;

}

else { carp "Test::plan(): skipping unrecognized directive '$k'" }

}

my @todo = sort { $a <=> $b } keys %todo;

if (@todo) {

print $TESTOUT "1..$max todo ".join(' ', @todo).";\n";

} else {

print $TESTOUT "1..$max\n";

}

++$planned;

}

sub to_value {

my ($v) = @_;

(ref $v or '') eq 'CODE' ? $v->() : $v;

}

sub ok ($;$$) {

croak "ok: plan before you test!" if !$planned;

my ($pkg,$file,$line) = caller($TestLevel);

my $repetition = ++$history{"$file:$line"};

my $context = ("$file at line $line".

($repetition > 1 ? " fail \#$repetition" : ''));

my $ok=0;

my $result = to_value(shift);

my ($expected,$diag);

if (@_ == 0) {

$ok = $result;

} else {

$expected = to_value(shift);

my ($regex,$ignore);

if (!defined $expected) {

$ok = !defined $result;

} elsif (!defined $result) {

$ok = 0;

} elsif ((ref($expected)||'') eq 'Regexp') {

$ok = $result =~ /$expected/;

} elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or

($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {

$ok = $result =~ /$regex/;

} else {

$ok = $result eq $expected;

}

}

my $todo = $todo{$ntest};

if ($todo and $ok) {

$context .= ' TODO?!' if $todo;

print $TESTOUT "ok $ntest # ($context)\n";

} else {

# Issuing two separate print()s causes severe trouble with

# Test::Harness on VMS. The "not "'s for failed tests occur

# on a separate line and would not get counted as failures.

#print $TESTOUT "not " if !$ok;

#print $TESTOUT "ok $ntest\n";

# Replace with a single print() as a workaround:

my $okline = '';

$okline = "not " if !$ok;

$okline .= "ok $ntest\n";

print $TESTOUT $okline;

if (!$ok) {

my $detail = { 'repetition' => $repetition, 'package' => $pkg,

'result' => $result, 'todo' => $todo };

$$detail{expected} = $expected if defined $expected;

$diag = $$detail{diagnostic} = to_value(shift) if @_;

$context .= ' *TODO*' if $todo;

if (!defined $expected) {

if (!$diag) {

print $TESTOUT "# Failed test $ntest in $context\n";

} else {

print $TESTOUT "# Failed test $ntest in $context: $diag\n";

}

} else {

my $prefix = "Test $ntest";

print $TESTOUT "# $prefix got: ".

(defined $result? "'$result'":'<UNDEF>')." ($context)\n";

$prefix = ' ' x (length($prefix) - 5);

if ((ref($expected)||'') eq 'Regexp') {

$expected = 'qr/'.$expected.'/'

} else {

$expected = "'$expected'";

}

if (!$diag) {

print $TESTOUT "# $prefix Expected: $expected\n";

} else {

print $TESTOUT "# $prefix Expected: $expected ($diag)\n";

}

}

push @FAILDETAIL, $detail;

}

}

++ $ntest;

$ok;

}

sub skip ($$;$$) {

my $whyskip = to_value(shift);

if ($whyskip) {

$whyskip = 'skip' if $whyskip =~ m/^\d+$/;

print $TESTOUT "ok $ntest # $whyskip\n";

++ $ntest;

1;

} else {

local($TestLevel) = $TestLevel+1; #ignore this stack frame

&ok;

}

}

END {

$ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;

}

1;