use
5.006;
sub
_carp {
my
(
$file
,
$line
) = (
caller
(1) )[ 1, 2 ];
return
warn
@_
,
" at $file line $line\n"
;
}
our
$VERSION
=
'0.84'
;
$VERSION
=
eval
$VERSION
;
our
@ISA
=
qw(Test::Builder::Module)
;
our
@EXPORT
=
qw(ok use_ok require_ok
is isnt like unlike is_deeply
cmp_ok
skip todo todo_skip
pass fail
eq_array eq_hash eq_set
$TODO
plan
can_ok isa_ok new_ok
diag note explain
BAIL_OUT
)
;
sub
plan {
my
$tb
= Test::More->builder;
return
$tb
->plan(
@_
);
}
sub
import_extra {
my
$class
=
shift
;
my
$list
=
shift
;
my
@other
= ();
my
$idx
= 0;
while
(
$idx
<= $
my
$item
=
$list
->[
$idx
];
if
(
defined
$item
and
$item
eq
'no_diag'
) {
$class
->builder->no_diag(1);
}
else
{
push
@other
,
$item
;
}
$idx
++;
}
@$list
=
@other
;
return
;
}
sub
ok ($;$) {
my
(
$test
,
$name
) =
@_
;
my
$tb
= Test::More->builder;
return
$tb
->ok(
$test
,
$name
);
}
sub
is ($$;$) {
my
$tb
= Test::More->builder;
return
$tb
->is_eq(
@_
);
}
sub
isnt ($$;$) {
my
$tb
= Test::More->builder;
return
$tb
->isnt_eq(
@_
);
}
*isn
't = \
&isnt
;
sub
like ($$;$) {
my
$tb
= Test::More->builder;
return
$tb
->like(
@_
);
}
sub
unlike ($$;$) {
my
$tb
= Test::More->builder;
return
$tb
->unlike(
@_
);
}
sub
cmp_ok($$$;$) {
my
$tb
= Test::More->builder;
return
$tb
->cmp_ok(
@_
);
}
sub
can_ok ($@) {
my
(
$proto
,
@methods
) =
@_
;
my
$class
=
ref
$proto
||
$proto
;
my
$tb
= Test::More->builder;
unless
(
$class
) {
my
$ok
=
$tb
->ok( 0,
"->can(...)"
);
$tb
->diag(
' can_ok() called with empty class or reference'
);
return
$ok
;
}
unless
(
@methods
) {
my
$ok
=
$tb
->ok( 0,
"$class->can(...)"
);
$tb
->diag(
' can_ok() called with no methods'
);
return
$ok
;
}
my
@nok
= ();
foreach
my
$method
(
@methods
) {
$tb
->_try(
sub
{
$proto
->can(
$method
) } ) or
push
@nok
,
$method
;
}
my
$name
= (
@methods
== 1) ?
"$class->can('$methods[0]')"
:
"$class->can(...)"
;
my
$ok
=
$tb
->ok( !
@nok
,
$name
);
$tb
->diag(
map
" $class->can('$_') failed\n"
,
@nok
);
return
$ok
;
}
sub
isa_ok ($$;$) {
my
(
$object
,
$class
,
$obj_name
) =
@_
;
my
$tb
= Test::More->builder;
my
$diag
;
$obj_name
=
'The object'
unless
defined
$obj_name
;
my
$name
=
"$obj_name isa $class"
;
if
( !
defined
$object
) {
$diag
=
"$obj_name isn't defined"
;
}
elsif
( !
ref
$object
) {
$diag
=
"$obj_name isn't a reference"
;
}
else
{
my
(
$rslt
,
$error
) =
$tb
->_try(
sub
{
$object
->isa(
$class
) } );
if
(
$error
) {
if
(
$error
=~ /^Can't call method
"isa"
on unblessed reference/ ) {
if
( !UNIVERSAL::isa(
$object
,
$class
) ) {
my
$ref
=
ref
$object
;
$diag
=
"$obj_name isn't a '$class' it's a '$ref'"
;
}
}
else
{
die
<<WHOA;
WHOA! I tried to call ->isa on your object and got some weird error.
Here's the error.
$error
WHOA
}
}
elsif
( !
$rslt
) {
my
$ref
=
ref
$object
;
$diag
=
"$obj_name isn't a '$class' it's a '$ref'"
;
}
}
my
$ok
;
if
(
$diag
) {
$ok
=
$tb
->ok( 0,
$name
);
$tb
->diag(
" $diag\n"
);
}
else
{
$ok
=
$tb
->ok( 1,
$name
);
}
return
$ok
;
}
sub
new_ok {
my
$tb
= Test::More->builder;
$tb
->croak(
"new_ok() must be given at least a class"
)
unless
@_
;
my
(
$class
,
$args
,
$object_name
) =
@_
;
$args
||= [];
$object_name
=
"The object"
unless
defined
$object_name
;
my
$obj
;
my
(
$success
,
$error
) =
$tb
->_try(
sub
{
$obj
=
$class
->new(
@$args
); 1 } );
if
(
$success
) {
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
isa_ok
$obj
,
$class
,
$object_name
;
}
else
{
$tb
->ok( 0,
"new() died"
);
$tb
->diag(
" Error was: $error"
);
}
return
$obj
;
}
sub
pass (;$) {
my
$tb
= Test::More->builder;
return
$tb
->ok( 1,
@_
);
}
sub
fail (;$) {
my
$tb
= Test::More->builder;
return
$tb
->ok( 0,
@_
);
}
sub
use_ok ($;@) {
my
(
$module
,
@imports
) =
@_
;
@imports
= ()
unless
@imports
;
my
$tb
= Test::More->builder;
my
(
$pack
,
$filename
,
$line
) =
caller
;
my
$code
;
if
(
@imports
== 1 and
$imports
[0] =~ /^\d+(?:\.\d+)?$/ ) {
$code
=
<<USE;
package $pack;
use $module $imports[0];
1;
USE
}
else
{
$code
=
<<USE;
package $pack;
use $module \@{\$args[0]};
1;
USE
}
my
(
$eval_result
,
$eval_error
) = _eval(
$code
, \
@imports
);
my
$ok
=
$tb
->ok(
$eval_result
,
"use $module;"
);
unless
(
$ok
) {
chomp
$eval_error
;
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
{BEGIN failed--compilation aborted at
$filename
line
$line
.}m;
$tb
->diag(
<<DIAGNOSTIC);
Tried to use '$module'.
Error: $eval_error
DIAGNOSTIC
}
return
$ok
;
}
sub
_eval {
my
(
$code
,
@args
) =
@_
;
my
(
$sigdie
,
$eval_result
,
$eval_error
);
{
local
( $@, $!,
$SIG
{__DIE__} );
$eval_result
=
eval
$code
;
$eval_error
= $@;
$sigdie
=
$SIG
{__DIE__} ||
undef
;
}
$SIG
{__DIE__} =
$sigdie
if
defined
$sigdie
;
return
(
$eval_result
,
$eval_error
);
}
sub
require_ok ($) {
my
(
$module
) =
shift
;
my
$tb
= Test::More->builder;
my
$pack
=
caller
;
$module
=
qq['$module']
unless
_is_module_name(
$module
);
my
$code
=
<<REQUIRE;
package $pack;
require $module;
1;
REQUIRE
my
(
$eval_result
,
$eval_error
) = _eval(
$code
);
my
$ok
=
$tb
->ok(
$eval_result
,
"require $module;"
);
unless
(
$ok
) {
chomp
$eval_error
;
$tb
->diag(
<<DIAGNOSTIC);
Tried to require '$module'.
Error: $eval_error
DIAGNOSTIC
}
return
$ok
;
}
sub
_is_module_name {
my
$module
=
shift
;
$module
=~ s/\b::\b//g;
return
$module
=~ /^[a-zA-Z]\w*$/ ? 1 : 0;
}
our
(
@Data_Stack
,
%Refs_Seen
);
my
$DNE
=
bless
[],
'Does::Not::Exist'
;
sub
_dne {
return
ref
$_
[0] eq
ref
$DNE
;
}
sub
is_deeply {
my
$tb
= Test::More->builder;
unless
(
@_
== 2 or
@_
== 3 ) {
my
$msg
=
<<'WARNING';
is_deeply() takes two or three args, you gave %d.
This usually means you passed an array or hash instead
of a reference to it
WARNING
chop
$msg
;
_carp
sprintf
$msg
,
scalar
@_
;
return
$tb
->ok(0);
}
my
(
$got
,
$expected
,
$name
) =
@_
;
$tb
->_unoverload_str( \
$expected
, \
$got
);
my
$ok
;
if
( !
ref
$got
and !
ref
$expected
) {
$ok
=
$tb
->is_eq(
$got
,
$expected
,
$name
);
}
elsif
( !
ref
$got
xor !
ref
$expected
) {
$ok
=
$tb
->ok( 0,
$name
);
$tb
->diag( _format_stack({
vals
=> [
$got
,
$expected
] }) );
}
else
{
local
@Data_Stack
= ();
if
( _deep_check(
$got
,
$expected
) ) {
$ok
=
$tb
->ok( 1,
$name
);
}
else
{
$ok
=
$tb
->ok( 0,
$name
);
$tb
->diag( _format_stack(
@Data_Stack
) );
}
}
return
$ok
;
}
sub
_format_stack {
my
(
@Stack
) =
@_
;
my
$var
=
'$FOO'
;
my
$did_arrow
= 0;
foreach
my
$entry
(
@Stack
) {
my
$type
=
$entry
->{type} ||
''
;
my
$idx
=
$entry
->{
'idx'
};
if
(
$type
eq
'HASH'
) {
$var
.=
"->"
unless
$did_arrow
++;
$var
.=
"{$idx}"
;
}
elsif
(
$type
eq
'ARRAY'
) {
$var
.=
"->"
unless
$did_arrow
++;
$var
.=
"[$idx]"
;
}
elsif
(
$type
eq
'REF'
) {
$var
=
"\${$var}"
;
}
}
my
@vals
= @{
$Stack
[-1]{vals} }[ 0, 1 ];
my
@vars
= ();
(
$vars
[0] =
$var
) =~ s/\
$FOO
/ \
$got
/;
(
$vars
[1] =
$var
) =~ s/\
$FOO
/\
$expected
/;
my
$out
=
"Structures begin differing at:\n"
;
foreach
my
$idx
( 0 ..
$#vals
) {
my
$val
=
$vals
[
$idx
];
$vals
[
$idx
]
= !
defined
$val
?
'undef'
: _dne(
$val
) ?
"Does not exist"
:
ref
$val
?
"$val"
:
"'$val'"
;
}
$out
.=
"$vars[0] = $vals[0]\n"
;
$out
.=
"$vars[1] = $vals[1]\n"
;
$out
=~ s/^/ /msg;
return
$out
;
}
sub
_type {
my
$thing
=
shift
;
return
''
if
!
ref
$thing
;
for
my
$type
(
qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)
) {
return
$type
if
UNIVERSAL::isa(
$thing
,
$type
);
}
return
''
;
}
sub
diag {
return
Test::More->builder->diag(
@_
);
}
sub
note {
return
Test::More->builder->note(
@_
);
}
sub
explain {
return
Test::More->builder->explain(
@_
);
}
sub
skip {
my
(
$why
,
$how_many
) =
@_
;
my
$tb
= Test::More->builder;
unless
(
defined
$how_many
) {
_carp
"skip() needs to know \$how_many tests are in the block"
unless
$tb
->has_plan eq
'no_plan'
;
$how_many
= 1;
}
if
(
defined
$how_many
and
$how_many
=~ /\D/ ) {
_carp
"skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"
;
$how_many
= 1;
}
for
( 1 ..
$how_many
) {
$tb
->skip(
$why
);
}
no
warnings
'exiting'
;
last
SKIP;
}
sub
todo_skip {
my
(
$why
,
$how_many
) =
@_
;
my
$tb
= Test::More->builder;
unless
(
defined
$how_many
) {
_carp
"todo_skip() needs to know \$how_many tests are in the block"
unless
$tb
->has_plan eq
'no_plan'
;
$how_many
= 1;
}
for
( 1 ..
$how_many
) {
$tb
->todo_skip(
$why
);
}
no
warnings
'exiting'
;
last
TODO;
}
sub
BAIL_OUT {
my
$reason
=
shift
;
my
$tb
= Test::More->builder;
$tb
->BAIL_OUT(
$reason
);
}
sub
eq_array {
local
@Data_Stack
= ();
_deep_check(
@_
);
}
sub
_eq_array {
my
(
$a1
,
$a2
) =
@_
;
if
(
grep
_type(
$_
) ne
'ARRAY'
,
$a1
,
$a2
) {
warn
"eq_array passed a non-array ref"
;
return
0;
}
return
1
if
$a1
eq
$a2
;
my
$ok
= 1;
my
$max
=
$#$a1
>
$#$a2
?
$#$a1
:
$#$a2
;
for
( 0 ..
$max
) {
my
$e1
=
$_
>
$#$a1
?
$DNE
:
$a1
->[
$_
];
my
$e2
=
$_
>
$#$a2
?
$DNE
:
$a2
->[
$_
];
push
@Data_Stack
, {
type
=>
'ARRAY'
,
idx
=>
$_
,
vals
=> [
$e1
,
$e2
] };
$ok
= _deep_check(
$e1
,
$e2
);
pop
@Data_Stack
if
$ok
;
last
unless
$ok
;
}
return
$ok
;
}
sub
_deep_check {
my
(
$e1
,
$e2
) =
@_
;
my
$tb
= Test::More->builder;
my
$ok
= 0;
local
%Refs_Seen
=
%Refs_Seen
;
{
no
warnings
'uninitialized'
;
$tb
->_unoverload_str( \
$e1
, \
$e2
);
my
$same_ref
= !( !
ref
$e1
xor !
ref
$e2
);
my
$not_ref
= ( !
ref
$e1
and !
ref
$e2
);
if
(
defined
$e1
xor
defined
$e2
) {
$ok
= 0;
}
elsif
( _dne(
$e1
) xor _dne(
$e2
) ) {
$ok
= 0;
}
elsif
(
$same_ref
and(
$e1
eq
$e2
) ) {
$ok
= 1;
}
elsif
(
$not_ref
) {
push
@Data_Stack
, {
type
=>
''
,
vals
=> [
$e1
,
$e2
] };
$ok
= 0;
}
else
{
if
(
$Refs_Seen
{
$e1
} ) {
return
$Refs_Seen
{
$e1
} eq
$e2
;
}
else
{
$Refs_Seen
{
$e1
} =
"$e2"
;
}
my
$type
= _type(
$e1
);
$type
=
'DIFFERENT'
unless
_type(
$e2
) eq
$type
;
if
(
$type
eq
'DIFFERENT'
) {
push
@Data_Stack
, {
type
=>
$type
,
vals
=> [
$e1
,
$e2
] };
$ok
= 0;
}
elsif
(
$type
eq
'ARRAY'
) {
$ok
= _eq_array(
$e1
,
$e2
);
}
elsif
(
$type
eq
'HASH'
) {
$ok
= _eq_hash(
$e1
,
$e2
);
}
elsif
(
$type
eq
'REF'
) {
push
@Data_Stack
, {
type
=>
$type
,
vals
=> [
$e1
,
$e2
] };
$ok
= _deep_check(
$$e1
,
$$e2
);
pop
@Data_Stack
if
$ok
;
}
elsif
(
$type
eq
'SCALAR'
) {
push
@Data_Stack
, {
type
=>
'REF'
,
vals
=> [
$e1
,
$e2
] };
$ok
= _deep_check(
$$e1
,
$$e2
);
pop
@Data_Stack
if
$ok
;
}
elsif
(
$type
) {
push
@Data_Stack
, {
type
=>
$type
,
vals
=> [
$e1
,
$e2
] };
$ok
= 0;
}
else
{
_whoa( 1,
"No type in _deep_check"
);
}
}
}
return
$ok
;
}
sub
_whoa {
my
(
$check
,
$desc
) =
@_
;
if
(
$check
) {
die
<<"WHOA";
WHOA! $desc
This should never happen! Please contact the author immediately!
WHOA
}
}
sub
eq_hash {
local
@Data_Stack
= ();
return
_deep_check(
@_
);
}
sub
_eq_hash {
my
(
$a1
,
$a2
) =
@_
;
if
(
grep
_type(
$_
) ne
'HASH'
,
$a1
,
$a2
) {
warn
"eq_hash passed a non-hash ref"
;
return
0;
}
return
1
if
$a1
eq
$a2
;
my
$ok
= 1;
my
$bigger
=
keys
%$a1
>
keys
%$a2
?
$a1
:
$a2
;
foreach
my
$k
(
keys
%$bigger
) {
my
$e1
=
exists
$a1
->{
$k
} ?
$a1
->{
$k
} :
$DNE
;
my
$e2
=
exists
$a2
->{
$k
} ?
$a2
->{
$k
} :
$DNE
;
push
@Data_Stack
, {
type
=>
'HASH'
,
idx
=>
$k
,
vals
=> [
$e1
,
$e2
] };
$ok
= _deep_check(
$e1
,
$e2
);
pop
@Data_Stack
if
$ok
;
last
unless
$ok
;
}
return
$ok
;
}
sub
eq_set {
my
(
$a1
,
$a2
) =
@_
;
return
0
unless
@$a1
==
@$a2
;
no
warnings
'uninitialized'
;
return
eq_array(
[
grep
(
ref
,
@$a1
),
sort
(
grep
( !
ref
,
@$a1
) ) ],
[
grep
(
ref
,
@$a2
),
sort
(
grep
( !
ref
,
@$a2
) ) ],
);
}
1;