use
5.004;
$^C ||= 0;
$VERSION
=
'0.74'
;
$VERSION
=
eval
$VERSION
;
BEGIN {
if
( $] >= 5.008001 &&
$Config
{useithreads} &&
$INC
{
'threads.pm'
}) {
*share
=
sub
(\[$@%]) {
my
$type
=
ref
$_
[0];
my
$data
;
if
(
$type
eq
'HASH'
) {
%$data
= %{
$_
[0]};
}
elsif
(
$type
eq
'ARRAY'
) {
@$data
= @{
$_
[0]};
}
elsif
(
$type
eq
'SCALAR'
) {
$$data
= ${
$_
[0]};
}
else
{
die
(
"Unknown type: "
.
$type
);
}
$_
[0] =
&threads::shared::share
(
$_
[0]);
if
(
$type
eq
'HASH'
) {
%{
$_
[0]} =
%$data
;
}
elsif
(
$type
eq
'ARRAY'
) {
@{
$_
[0]} =
@$data
;
}
elsif
(
$type
eq
'SCALAR'
) {
${
$_
[0]} =
$$data
;
}
else
{
die
(
"Unknown type: "
.
$type
);
}
return
$_
[0];
};
}
else
{
*share
=
sub
{
return
$_
[0] };
*lock
=
sub
{ 0 };
}
}
my
$Test
= Test::Builder->new;
sub
new {
my
(
$class
) =
shift
;
$Test
||=
$class
->create;
return
$Test
;
}
sub
create {
my
$class
=
shift
;
my
$self
=
bless
{},
$class
;
$self
->
reset
;
return
$self
;
}
sub
reset
{
my
(
$self
) =
@_
;
$Level
= 1;
$self
->{Test_Died} = 0;
$self
->{Have_Plan} = 0;
$self
->{No_Plan} = 0;
$self
->{Original_Pid} = $$;
share(
$self
->{Curr_Test});
$self
->{Curr_Test} = 0;
$self
->{Test_Results} =
&share
([]);
$self
->{Exported_To} =
undef
;
$self
->{Expected_Tests} = 0;
$self
->{Skip_All} = 0;
$self
->{Use_Nums} = 1;
$self
->{No_Header} = 0;
$self
->{No_Ending} = 0;
$self
->_dup_stdhandles
unless
$^C;
return
undef
;
}
sub
exported_to {
my
(
$self
,
$pack
) =
@_
;
if
(
defined
$pack
) {
$self
->{Exported_To} =
$pack
;
}
return
$self
->{Exported_To};
}
sub
plan {
my
(
$self
,
$cmd
,
$arg
) =
@_
;
return
unless
$cmd
;
local
$Level
=
$Level
+ 1;
if
(
$self
->{Have_Plan} ) {
$self
->croak(
"You tried to plan twice"
);
}
if
(
$cmd
eq
'no_plan'
) {
$self
->no_plan;
}
elsif
(
$cmd
eq
'skip_all'
) {
return
$self
->skip_all(
$arg
);
}
elsif
(
$cmd
eq
'tests'
) {
if
(
$arg
) {
local
$Level
=
$Level
+ 1;
return
$self
->expected_tests(
$arg
);
}
elsif
( !
defined
$arg
) {
$self
->croak(
"Got an undefined number of tests"
);
}
elsif
( !
$arg
) {
$self
->croak(
"You said to run 0 tests"
);
}
}
else
{
my
@args
=
grep
{
defined
} (
$cmd
,
$arg
);
$self
->croak(
"plan() doesn't understand @args"
);
}
return
1;
}
sub
expected_tests {
my
$self
=
shift
;
my
(
$max
) =
@_
;
if
(
@_
) {
$self
->croak(
"Number of tests must be a positive integer. You gave it '$max'"
)
unless
$max
=~ /^\+?\d+$/ and
$max
> 0;
$self
->{Expected_Tests} =
$max
;
$self
->{Have_Plan} = 1;
$self
->_print(
"1..$max\n"
)
unless
$self
->no_header;
}
return
$self
->{Expected_Tests};
}
sub
no_plan {
my
$self
=
shift
;
$self
->{No_Plan} = 1;
$self
->{Have_Plan} = 1;
}
sub
has_plan {
my
$self
=
shift
;
return
(
$self
->{Expected_Tests})
if
$self
->{Expected_Tests};
return
(
'no_plan'
)
if
$self
->{No_Plan};
return
(
undef
);
};
sub
skip_all {
my
(
$self
,
$reason
) =
@_
;
my
$out
=
"1..0"
;
$out
.=
" # Skip $reason"
if
$reason
;
$out
.=
"\n"
;
$self
->{Skip_All} = 1;
$self
->_print(
$out
)
unless
$self
->no_header;
exit
(0);
}
sub
ok {
my
(
$self
,
$test
,
$name
) =
@_
;
$test
=
$test
? 1 : 0;
$self
->_plan_check;
lock
$self
->{Curr_Test};
$self
->{Curr_Test}++;
$self
->_unoverload_str(\
$name
);
$self
->diag(
<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
You named your test '$name'. You shouldn't use numbers for your test names.
Very confusing.
ERR
my
(
$pack
,
$file
,
$line
) =
$self
->
caller
;
my
$todo
=
$self
->todo(
$pack
);
$self
->_unoverload_str(\
$todo
);
my
$out
;
my
$result
=
&share
({});
unless
(
$test
) {
$out
.=
"not "
;
@$result
{
'ok'
,
'actual_ok'
} = ( (
$todo
? 1 : 0 ), 0 );
}
else
{
@$result
{
'ok'
,
'actual_ok'
} = ( 1,
$test
);
}
$out
.=
"ok"
;
$out
.=
" $self->{Curr_Test}"
if
$self
->use_numbers;
if
(
defined
$name
) {
$name
=~ s|
$out
.=
" - $name"
;
$result
->{name} =
$name
;
}
else
{
$result
->{name} =
''
;
}
if
(
$todo
) {
$out
.=
" # TODO $todo"
;
$result
->{reason} =
$todo
;
$result
->{type} =
'todo'
;
}
else
{
$result
->{reason} =
''
;
$result
->{type} =
''
;
}
$self
->{Test_Results}[
$self
->{Curr_Test}-1] =
$result
;
$out
.=
"\n"
;
$self
->_print(
$out
);
unless
(
$test
) {
my
$msg
=
$todo
?
"Failed (TODO)"
:
"Failed"
;
$self
->_print_diag(
"\n"
)
if
$ENV
{HARNESS_ACTIVE};
if
(
defined
$name
) {
$self
->diag(
qq[ $msg test '$name'\n]
);
$self
->diag(
qq[ at $file line $line.\n]
);
}
else
{
$self
->diag(
qq[ $msg test at $file line $line.\n]
);
}
}
return
$test
? 1 : 0;
}
sub
_unoverload {
my
$self
=
shift
;
my
$type
=
shift
;
$self
->_try(
sub
{
require
overload } ) ||
return
;
foreach
my
$thing
(
@_
) {
if
(
$self
->_is_object(
$$thing
) ) {
if
(
my
$string_meth
= overload::Method(
$$thing
,
$type
) ) {
$$thing
=
$$thing
->
$string_meth
();
}
}
}
}
sub
_is_object {
my
(
$self
,
$thing
) =
@_
;
return
$self
->_try(
sub
{
ref
$thing
&&
$thing
->isa(
'UNIVERSAL'
) }) ? 1 : 0;
}
sub
_unoverload_str {
my
$self
=
shift
;
$self
->_unoverload(
q[""]
,
@_
);
}
sub
_unoverload_num {
my
$self
=
shift
;
$self
->_unoverload(
'0+'
,
@_
);
for
my
$val
(
@_
) {
next
unless
$self
->_is_dualvar(
$$val
);
$$val
=
$$val
+0;
}
}
sub
_is_dualvar {
my
(
$self
,
$val
) =
@_
;
local
$^W = 0;
my
$numval
=
$val
+0;
return
1
if
$numval
!= 0 and
$numval
ne
$val
;
}
sub
is_eq {
my
(
$self
,
$got
,
$expect
,
$name
) =
@_
;
local
$Level
=
$Level
+ 1;
$self
->_unoverload_str(\
$got
, \
$expect
);
if
( !
defined
$got
|| !
defined
$expect
) {
my
$test
= !
defined
$got
&& !
defined
$expect
;
$self
->ok(
$test
,
$name
);
$self
->_is_diag(
$got
,
'eq'
,
$expect
)
unless
$test
;
return
$test
;
}
return
$self
->cmp_ok(
$got
,
'eq'
,
$expect
,
$name
);
}
sub
is_num {
my
(
$self
,
$got
,
$expect
,
$name
) =
@_
;
local
$Level
=
$Level
+ 1;
$self
->_unoverload_num(\
$got
, \
$expect
);
if
( !
defined
$got
|| !
defined
$expect
) {
my
$test
= !
defined
$got
&& !
defined
$expect
;
$self
->ok(
$test
,
$name
);
$self
->_is_diag(
$got
,
'=='
,
$expect
)
unless
$test
;
return
$test
;
}
return
$self
->cmp_ok(
$got
,
'=='
,
$expect
,
$name
);
}
sub
_is_diag {
my
(
$self
,
$got
,
$type
,
$expect
) =
@_
;
foreach
my
$val
(\
$got
, \
$expect
) {
if
(
defined
$$val
) {
if
(
$type
eq
'eq'
) {
$$val
=
"'$$val'"
}
else
{
$self
->_unoverload_num(
$val
);
}
}
else
{
$$val
=
'undef'
;
}
}
return
$self
->diag(
sprintf
<<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
DIAGNOSTIC
}
sub
isnt_eq {
my
(
$self
,
$got
,
$dont_expect
,
$name
) =
@_
;
local
$Level
=
$Level
+ 1;
if
( !
defined
$got
|| !
defined
$dont_expect
) {
my
$test
=
defined
$got
||
defined
$dont_expect
;
$self
->ok(
$test
,
$name
);
$self
->_cmp_diag(
$got
,
'ne'
,
$dont_expect
)
unless
$test
;
return
$test
;
}
return
$self
->cmp_ok(
$got
,
'ne'
,
$dont_expect
,
$name
);
}
sub
isnt_num {
my
(
$self
,
$got
,
$dont_expect
,
$name
) =
@_
;
local
$Level
=
$Level
+ 1;
if
( !
defined
$got
|| !
defined
$dont_expect
) {
my
$test
=
defined
$got
||
defined
$dont_expect
;
$self
->ok(
$test
,
$name
);
$self
->_cmp_diag(
$got
,
'!='
,
$dont_expect
)
unless
$test
;
return
$test
;
}
return
$self
->cmp_ok(
$got
,
'!='
,
$dont_expect
,
$name
);
}
sub
like {
my
(
$self
,
$this
,
$regex
,
$name
) =
@_
;
local
$Level
=
$Level
+ 1;
$self
->_regex_ok(
$this
,
$regex
,
'=~'
,
$name
);
}
sub
unlike {
my
(
$self
,
$this
,
$regex
,
$name
) =
@_
;
local
$Level
=
$Level
+ 1;
$self
->_regex_ok(
$this
,
$regex
,
'!~'
,
$name
);
}
my
%numeric_cmps
=
map
{ (
$_
, 1) }
(
"<"
,
"<="
,
">"
,
">="
,
"=="
,
"!="
,
"<=>"
);
sub
cmp_ok {
my
(
$self
,
$got
,
$type
,
$expect
,
$name
) =
@_
;
my
$unoverload
=
$numeric_cmps
{
$type
} ?
'_unoverload_num'
:
'_unoverload_str'
;
$self
->
$unoverload
(\
$got
, \
$expect
);
my
$test
;
{
local
($@,$!,
$SIG
{__DIE__});
my
$code
=
$self
->_caller_context;
$test
=
eval
"
$code
" . "
\
$got
$type
\
$expect
;";
}
local
$Level
=
$Level
+ 1;
my
$ok
=
$self
->ok(
$test
,
$name
);
unless
(
$ok
) {
if
(
$type
=~ /^(eq|==)$/ ) {
$self
->_is_diag(
$got
,
$type
,
$expect
);
}
else
{
$self
->_cmp_diag(
$got
,
$type
,
$expect
);
}
}
return
$ok
;
}
sub
_cmp_diag {
my
(
$self
,
$got
,
$type
,
$expect
) =
@_
;
$got
=
defined
$got
?
"'$got'"
:
'undef'
;
$expect
=
defined
$expect
?
"'$expect'"
:
'undef'
;
return
$self
->diag(
sprintf
<<DIAGNOSTIC, $got, $type, $expect);
%s
%s
%s
DIAGNOSTIC
}
sub
_caller_context {
my
$self
=
shift
;
my
(
$pack
,
$file
,
$line
) =
$self
->
caller
(1);
my
$code
=
''
;
$code
.=
"#line $line $file\n"
if
defined
$file
and
defined
$line
;
return
$code
;
}
sub
BAIL_OUT {
my
(
$self
,
$reason
) =
@_
;
$self
->{Bailed_Out} = 1;
$self
->_print(
"Bail out! $reason"
);
exit
255;
}
*BAILOUT
= \
&BAIL_OUT
;
sub
skip {
my
(
$self
,
$why
) =
@_
;
$why
||=
''
;
$self
->_unoverload_str(\
$why
);
$self
->_plan_check;
lock
(
$self
->{Curr_Test});
$self
->{Curr_Test}++;
$self
->{Test_Results}[
$self
->{Curr_Test}-1] =
&share
({
'ok'
=> 1,
actual_ok
=> 1,
name
=>
''
,
type
=>
'skip'
,
reason
=>
$why
,
});
my
$out
=
"ok"
;
$out
.=
" $self->{Curr_Test}"
if
$self
->use_numbers;
$out
.=
" # skip"
;
$out
.=
" $why"
if
length
$why
;
$out
.=
"\n"
;
$self
->_print(
$out
);
return
1;
}
sub
todo_skip {
my
(
$self
,
$why
) =
@_
;
$why
||=
''
;
$self
->_plan_check;
lock
(
$self
->{Curr_Test});
$self
->{Curr_Test}++;
$self
->{Test_Results}[
$self
->{Curr_Test}-1] =
&share
({
'ok'
=> 1,
actual_ok
=> 0,
name
=>
''
,
type
=>
'todo_skip'
,
reason
=>
$why
,
});
my
$out
=
"not ok"
;
$out
.=
" $self->{Curr_Test}"
if
$self
->use_numbers;
$out
.=
" # TODO & SKIP $why\n"
;
$self
->_print(
$out
);
return
1;
}
sub
maybe_regex {
my
(
$self
,
$regex
) =
@_
;
my
$usable_regex
=
undef
;
return
$usable_regex
unless
defined
$regex
;
my
(
$re
,
$opts
);
if
(
ref
$regex
eq
'Regexp'
) {
$usable_regex
=
$regex
;
}
elsif
( (
$re
,
$opts
) =
$regex
=~ m{^ /(.*)/ (\w*) $ }sx or
(
undef
,
$re
,
$opts
) =
$regex
=~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
)
{
$usable_regex
=
length
$opts
?
"(?$opts)$re"
:
$re
;
}
return
$usable_regex
;
};
sub
_regex_ok {
my
(
$self
,
$this
,
$regex
,
$cmp
,
$name
) =
@_
;
my
$ok
= 0;
my
$usable_regex
=
$self
->maybe_regex(
$regex
);
unless
(
defined
$usable_regex
) {
$ok
=
$self
->ok( 0,
$name
);
$self
->diag(
" '$regex' doesn't look much like a regex to me."
);
return
$ok
;
}
{
my
$test
;
my
$code
=
$self
->_caller_context;
local
($@, $!,
$SIG
{__DIE__});
$test
=
eval
"
$code
" .
q{$test = $this =~ /$usable_regex/ ? 1 : 0}
;
$test
= !
$test
if
$cmp
eq
'!~'
;
local
$Level
=
$Level
+ 1;
$ok
=
$self
->ok(
$test
,
$name
);
}
unless
(
$ok
) {
$this
=
defined
$this
?
"'$this'"
:
'undef'
;
my
$match
=
$cmp
eq
'=~'
?
"doesn't match"
:
"matches"
;
$self
->diag(
sprintf
<<DIAGNOSTIC, $this, $match, $regex);
%s
%13s '%s'
DIAGNOSTIC
}
return
$ok
;
}
sub
_try {
my
(
$self
,
$code
) =
@_
;
local
$!;
local
$@;
local
$SIG
{__DIE__};
my
$return
=
eval
{
$code
->() };
return
wantarray
? (
$return
, $@) :
$return
;
}
sub
is_fh {
my
$self
=
shift
;
my
$maybe_fh
=
shift
;
return
0
unless
defined
$maybe_fh
;
return
1
if
ref
$maybe_fh
eq
'GLOB'
;
return
1
if
ref
\
$maybe_fh
eq
'GLOB'
;
return
eval
{
$maybe_fh
->isa(
"IO::Handle"
) } ||
eval
{ (
tied
(
$maybe_fh
) ||
''
)->can(
'TIEHANDLE'
) };
}
sub
level {
my
(
$self
,
$level
) =
@_
;
if
(
defined
$level
) {
$Level
=
$level
;
}
return
$Level
;
}
sub
use_numbers {
my
(
$self
,
$use_nums
) =
@_
;
if
(
defined
$use_nums
) {
$self
->{Use_Nums} =
$use_nums
;
}
return
$self
->{Use_Nums};
}
foreach
my
$attribute
(
qw(No_Header No_Ending No_Diag)
) {
my
$method
=
lc
$attribute
;
my
$code
=
sub
{
my
(
$self
,
$no
) =
@_
;
if
(
defined
$no
) {
$self
->{
$attribute
} =
$no
;
}
return
$self
->{
$attribute
};
};
no
strict
'refs'
;
*{__PACKAGE__.
'::'
.
$method
} =
$code
;
}
sub
diag {
my
(
$self
,
@msgs
) =
@_
;
return
if
$self
->no_diag;
return
unless
@msgs
;
return
if
$^C;
my
$msg
=
join
''
,
map
{
defined
(
$_
) ?
$_
:
'undef'
}
@msgs
;
$msg
=~ s/^/
$msg
.=
"\n"
unless
$msg
=~ /\n\Z/;
local
$Level
=
$Level
+ 1;
$self
->_print_diag(
$msg
);
return
0;
}
sub
_print {
my
(
$self
,
@msgs
) =
@_
;
return
if
$^C;
my
$msg
=
join
''
,
@msgs
;
local
($\, $", $,) = (
undef
,
' '
,
''
);
my
$fh
=
$self
->output;
$msg
=~ s/\n(.)/\n
$msg
.=
"\n"
unless
$msg
=~ /\n\Z/;
print
$fh
$msg
;
}
sub
_print_diag {
my
$self
=
shift
;
local
($\, $", $,) = (
undef
,
' '
,
''
);
my
$fh
=
$self
->todo ?
$self
->todo_output :
$self
->failure_output;
print
$fh
@_
;
}
sub
output {
my
(
$self
,
$fh
) =
@_
;
if
(
defined
$fh
) {
$self
->{Out_FH} =
$self
->_new_fh(
$fh
);
}
return
$self
->{Out_FH};
}
sub
failure_output {
my
(
$self
,
$fh
) =
@_
;
if
(
defined
$fh
) {
$self
->{Fail_FH} =
$self
->_new_fh(
$fh
);
}
return
$self
->{Fail_FH};
}
sub
todo_output {
my
(
$self
,
$fh
) =
@_
;
if
(
defined
$fh
) {
$self
->{Todo_FH} =
$self
->_new_fh(
$fh
);
}
return
$self
->{Todo_FH};
}
sub
_new_fh {
my
$self
=
shift
;
my
(
$file_or_fh
) =
shift
;
my
$fh
;
if
(
$self
->is_fh(
$file_or_fh
) ) {
$fh
=
$file_or_fh
;
}
else
{
$fh
=
do
{
local
*FH
};
open
$fh
,
">$file_or_fh"
or
$self
->croak(
"Can't open test output log $file_or_fh: $!"
);
_autoflush(
$fh
);
}
return
$fh
;
}
sub
_autoflush {
my
(
$fh
) =
shift
;
my
$old_fh
=
select
$fh
;
$| = 1;
select
$old_fh
;
}
sub
_dup_stdhandles {
my
$self
=
shift
;
$self
->_open_testhandles;
_autoflush(\
*TESTOUT
);
_autoflush(\
*STDOUT
);
_autoflush(\
*TESTERR
);
_autoflush(\
*STDERR
);
$self
->output(\
*TESTOUT
);
$self
->failure_output(\
*TESTERR
);
$self
->todo_output(\
*TESTOUT
);
}
my
$Opened_Testhandles
= 0;
sub
_open_testhandles {
return
if
$Opened_Testhandles
;
open
(TESTOUT,
">&STDOUT"
) or
die
"Can't dup STDOUT: $!"
;
open
(TESTERR,
">&STDERR"
) or
die
"Can't dup STDERR: $!"
;
$Opened_Testhandles
= 1;
}
sub
_message_at_caller {
my
$self
=
shift
;
local
$Level
=
$Level
+ 1;
my
(
$pack
,
$file
,
$line
) =
$self
->
caller
;
return
join
(
""
,
@_
) .
" at $file line $line.\n"
;
}
sub
carp {
my
$self
=
shift
;
warn
$self
->_message_at_caller(
@_
);
}
sub
croak {
my
$self
=
shift
;
die
$self
->_message_at_caller(
@_
);
}
sub
_plan_check {
my
$self
=
shift
;
unless
(
$self
->{Have_Plan} ) {
local
$Level
=
$Level
+ 2;
$self
->croak(
"You tried to run a test without a plan"
);
}
}
sub
current_test {
my
(
$self
,
$num
) =
@_
;
lock
(
$self
->{Curr_Test});
if
(
defined
$num
) {
unless
(
$self
->{Have_Plan} ) {
$self
->croak(
"Can't change the current test number without a plan!"
);
}
$self
->{Curr_Test} =
$num
;
my
$test_results
=
$self
->{Test_Results};
if
(
$num
>
@$test_results
) {
my
$start
=
@$test_results
?
@$test_results
: 0;
for
(
$start
..
$num
-1) {
$test_results
->[
$_
] =
&share
({
'ok'
=> 1,
actual_ok
=>
undef
,
reason
=>
'incrementing test number'
,
type
=>
'unknown'
,
name
=>
undef
});
}
}
elsif
(
$num
<
@$test_results
) {
$
}
}
return
$self
->{Curr_Test};
}
sub
summary {
my
(
$self
) =
shift
;
return
map
{
$_
->{
'ok'
} } @{
$self
->{Test_Results} };
}
sub
details {
my
$self
=
shift
;
return
@{
$self
->{Test_Results} };
}
sub
todo {
my
(
$self
,
$pack
) =
@_
;
$pack
=
$pack
||
$self
->exported_to ||
$self
->
caller
(
$Level
);
return
0
unless
$pack
;
no
strict
'refs'
;
return
defined
${
$pack
.
'::TODO'
} ? ${
$pack
.
'::TODO'
}
: 0;
}
sub
caller
{
my
(
$self
,
$height
) =
@_
;
$height
||= 0;
my
@caller
= CORE::
caller
(
$self
->level +
$height
+ 1);
return
wantarray
?
@caller
:
$caller
[0];
}
sub
_sanity_check {
my
$self
=
shift
;
$self
->_whoa(
$self
->{Curr_Test} < 0,
'Says here you ran a negative number of tests!'
);
$self
->_whoa(!
$self
->{Have_Plan} and
$self
->{Curr_Test},
'Somehow your tests ran without a plan!'
);
$self
->_whoa(
$self
->{Curr_Test} != @{
$self
->{Test_Results} },
'Somehow you got a different number of results than tests ran!'
);
}
sub
_whoa {
my
(
$self
,
$check
,
$desc
) =
@_
;
if
(
$check
) {
local
$Level
=
$Level
+ 1;
$self
->croak(
<<"WHOA");
WHOA! $desc
This should never happen! Please contact the author immediately!
WHOA
}
}
sub
_my_exit {
$? =
$_
[0];
return
1;
}
$SIG
{__DIE__} =
sub
{
my
$in_eval
= 0;
for
(
my
$stack
= 1;
my
$sub
= (CORE::
caller
(
$stack
))[3];
$stack
++ ) {
$in_eval
= 1
if
$sub
=~ /^\(
eval
\)/;
}
$Test
->{Test_Died} = 1
unless
$in_eval
;
};
sub
_ending {
my
$self
=
shift
;
$self
->_sanity_check();
if
( (
$self
->{Original_Pid} != $$) or
(!
$self
->{Have_Plan} && !
$self
->{Test_Died}) or
$self
->{Bailed_Out}
)
{
_my_exit($?);
return
;
}
my
$test_results
=
$self
->{Test_Results};
if
(
@$test_results
) {
if
(
$self
->{No_Plan} ) {
$self
->_print(
"1..$self->{Curr_Test}\n"
)
unless
$self
->no_header;
$self
->{Expected_Tests} =
$self
->{Curr_Test};
}
my
$empty_result
=
&share
({});
for
my
$idx
( 0..
$self
->{Expected_Tests}-1 ) {
$test_results
->[
$idx
] =
$empty_result
unless
defined
$test_results
->[
$idx
];
}
my
$num_failed
=
grep
!
$_
->{
'ok'
},
@{
$test_results
}[0..
$self
->{Curr_Test}-1];
my
$num_extra
=
$self
->{Curr_Test} -
$self
->{Expected_Tests};
if
(
$num_extra
< 0 ) {
my
$s
=
$self
->{Expected_Tests} == 1 ?
''
:
's'
;
$self
->diag(
<<"FAIL");
Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
FAIL
}
elsif
(
$num_extra
> 0 ) {
my
$s
=
$self
->{Expected_Tests} == 1 ?
''
:
's'
;
$self
->diag(
<<"FAIL");
Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
FAIL
}
if
(
$num_failed
) {
my
$num_tests
=
$self
->{Curr_Test};
my
$s
=
$num_failed
== 1 ?
''
:
's'
;
my
$qualifier
=
$num_extra
== 0 ?
''
:
' run'
;
$self
->diag(
<<"FAIL");
Looks like you failed $num_failed test$s of $num_tests$qualifier.
FAIL
}
if
(
$self
->{Test_Died} ) {
$self
->diag(
<<"FAIL");
Looks like your test died just after $self->{Curr_Test}.
FAIL
_my_exit( 255 ) &&
return
;
}
my
$exit_code
;
if
(
$num_failed
) {
$exit_code
=
$num_failed
<= 254 ?
$num_failed
: 254;
}
elsif
(
$num_extra
!= 0 ) {
$exit_code
= 255;
}
else
{
$exit_code
= 0;
}
_my_exit(
$exit_code
) &&
return
;
}
elsif
(
$self
->{Skip_All} ) {
_my_exit( 0 ) &&
return
;
}
elsif
(
$self
->{Test_Died} ) {
$self
->diag(
<<'FAIL');
Looks like your test died before it could output anything.
FAIL
_my_exit( 255 ) &&
return
;
}
else
{
$self
->diag(
"No tests run!\n"
);
_my_exit( 255 ) &&
return
;
}
}
END {
$Test
->_ending
if
defined
$Test
and !
$Test
->no_ending;
}
1;