$Level
= 1;
my
$test
= 1;
my
$planned
;
my
$noplan
;
$TODO
= 0;
$NO_ENDING
= 0;
sub
plan {
my
$n
;
if
(
@_
== 1) {
$n
=
shift
;
if
(
$n
eq
'no_plan'
) {
undef
$n
;
$noplan
= 1;
}
}
else
{
my
%plan
=
@_
;
$n
=
$plan
{tests};
}
print
STDOUT
"1..$n\n"
unless
$noplan
;
$planned
=
$n
;
}
END {
my
$ran
=
$test
- 1;
if
(!
$NO_ENDING
) {
if
(
defined
$planned
&&
$planned
!=
$ran
) {
print
STDERR
"# Looks like you planned $planned tests but ran $ran.\n"
;
}
elsif
(
$noplan
) {
print
"1..$ran\n"
;
}
}
}
sub
_diag {
return
unless
@_
;
my
@mess
=
map
{ /^
map
{
split
/\n/ }
@_
;
my
$fh
=
$TODO
?
*STDOUT
:
*STDERR
;
print
$fh
@mess
;
}
sub
diag {
_diag(
@_
);
}
sub
skip_all {
if
(
@_
) {
print
STDOUT
"1..0 # Skipped: @_\n"
;
}
else
{
print
STDOUT
"1..0\n"
;
}
exit
(0);
}
sub
_ok {
my
(
$pass
,
$where
,
$name
,
@mess
) =
@_
;
my
$out
;
if
(
$name
) {
$name
=~ s/
$out
=
$pass
?
"ok $test - $name"
:
"not ok $test - $name"
;
}
else
{
$out
=
$pass
?
"ok $test"
:
"not ok $test"
;
}
$out
.=
" # TODO $TODO"
if
$TODO
;
print
STDOUT
"$out\n"
;
unless
(
$pass
) {
_diag
"# Failed $where\n"
;
}
_diag
@mess
;
$test
=
$test
+ 1;
return
$pass
;
}
sub
_where {
my
@caller
=
caller
(
$Level
);
return
"at $caller[1] line $caller[2]"
;
}
sub
ok ($@) {
my
(
$pass
,
$name
,
@mess
) =
@_
;
_ok(
$pass
, _where(),
$name
,
@mess
);
}
sub
_q {
my
$x
=
shift
;
return
'undef'
unless
defined
$x
;
my
$q
=
$x
;
$q
=~ s/\\/\\\\/g;
$q
=~ s/
'/\\'
/g;
return
"'$q'"
;
}
sub
_qq {
my
$x
=
shift
;
return
defined
$x
?
'"'
. display (
$x
) .
'"'
:
'undef'
;
};
my
%backslash_escape
;
foreach
my
$x
(
split
//,
'nrtfa\\\'"'
) {
$backslash_escape
{
ord
eval
"\"\\$x\""
} =
"\\$x"
;
}
sub
display {
my
@result
;
foreach
my
$x
(
@_
) {
if
(
defined
$x
and not
ref
$x
) {
my
$y
=
''
;
foreach
my
$c
(
unpack
(
"U*"
,
$x
)) {
if
(
$c
> 255) {
$y
.=
sprintf
"\\x{%x}"
,
$c
;
}
elsif
(
$backslash_escape
{
$c
}) {
$y
.=
$backslash_escape
{
$c
};
}
else
{
my
$z
=
chr
$c
;
$z
=
sprintf
"\\%03o"
,
$c
if
$z
=~ /[[:^
print
:]]/;
$y
.=
$z
;
}
}
$x
=
$y
;
}
return
$x
unless
wantarray
;
push
@result
,
$x
;
}
return
@result
;
}
sub
is ($$@) {
my
(
$got
,
$expected
,
$name
,
@mess
) =
@_
;
my
$pass
;
if
( !
defined
$got
|| !
defined
$expected
) {
$pass
= !
defined
$got
&& !
defined
$expected
;
}
else
{
$pass
=
$got
eq
$expected
;
}
unless
(
$pass
) {
unshift
(
@mess
,
"# got "
._q(
$got
).
"\n"
,
"# expected "
._q(
$expected
).
"\n"
);
}
_ok(
$pass
, _where(),
$name
,
@mess
);
}
sub
isnt ($$@) {
my
(
$got
,
$isnt
,
$name
,
@mess
) =
@_
;
my
$pass
;
if
( !
defined
$got
|| !
defined
$isnt
) {
$pass
=
defined
$got
||
defined
$isnt
;
}
else
{
$pass
=
$got
ne
$isnt
;
}
unless
(
$pass
) {
unshift
(
@mess
,
"# it should not be "
._q(
$got
).
"\n"
,
"# but it is.\n"
);
}
_ok(
$pass
, _where(),
$name
,
@mess
);
}
sub
cmp_ok ($$$@) {
my
(
$got
,
$type
,
$expected
,
$name
,
@mess
) =
@_
;
my
$pass
;
{
local
$^W = 0;
local
($@,$!);
$pass
=
eval
"\$got $type \$expected"
;
}
unless
(
$pass
) {
if
(
$got
eq
$expected
and
$type
!~
tr
/a-z//) {
unshift
@mess
,
"# $got - $expected = "
. (
$got
-
$expected
) .
"\n"
;
}
unshift
(
@mess
,
"# got "
._q(
$got
).
"\n"
,
"# expected $type "
._q(
$expected
).
"\n"
);
}
_ok(
$pass
, _where(),
$name
,
@mess
);
}
sub
within ($$$@) {
my
(
$got
,
$expected
,
$range
,
$name
,
@mess
) =
@_
;
my
$pass
;
if
(!
defined
$got
or !
defined
$expected
or !
defined
$range
) {
}
elsif
(
$got
!~
tr
/0-9// or
$expected
!~
tr
/0-9// or
$range
!~
tr
/0-9//) {
unshift
@mess
,
"# got, expected and range must be numeric\n"
;
}
elsif
(
$range
< 0) {
unshift
@mess
,
"# range must not be negative\n"
;
}
elsif
(
$range
== 0) {
$pass
=
$got
==
$expected
;
}
elsif
(
$expected
== 0) {
$pass
= (
$got
<=
$range
) && (
$got
>= -
$range
);
}
else
{
my
$diff
=
$got
-
$expected
;
$pass
=
abs
(
$diff
/
$expected
) <
$range
;
}
unless
(
$pass
) {
if
(
$got
eq
$expected
) {
unshift
@mess
,
"# $got - $expected = "
. (
$got
-
$expected
) .
"\n"
;
}
unshift
@mess
,
"# got "
._q(
$got
).
"\n"
,
"# expected "
._q(
$expected
).
" (within "
._q(
$range
).
")\n"
;
}
_ok(
$pass
, _where(),
$name
,
@mess
);
}
sub
like ($$@) { like_yn (0,
@_
) };
sub
unlike ($$@) { like_yn (1,
@_
) };
sub
like_yn ($$$@) {
my
(
$flip
,
$got
,
$expected
,
$name
,
@mess
) =
@_
;
my
$pass
;
$pass
=
$got
=~ /
$expected
/
if
!
$flip
;
$pass
=
$got
!~ /
$expected
/
if
$flip
;
unless
(
$pass
) {
unshift
(
@mess
,
"# got '$got'\n"
,
"# expected /$expected/\n"
);
}
local
$Level
= 2;
_ok(
$pass
, _where(),
$name
,
@mess
);
}
sub
pass {
_ok(1,
''
,
@_
);
}
sub
fail {
_ok(0, _where(),
@_
);
}
sub
curr_test {
$test
=
shift
if
@_
;
return
$test
;
}
sub
next_test {
my
$retval
=
$test
;
$test
=
$test
+ 1;
$retval
;
}
sub
skip {
my
$why
=
shift
;
my
$n
=
@_
?
shift
: 1;
for
(1..
$n
) {
print
STDOUT
"ok $test # skip: $why\n"
;
$test
=
$test
+ 1;
}
local
$^W = 0;
last
SKIP;
}
sub
todo_skip {
my
$why
=
shift
;
my
$n
=
@_
?
shift
: 1;
for
(1..
$n
) {
print
STDOUT
"not ok $test # TODO & SKIP: $why\n"
;
$test
=
$test
+ 1;
}
local
$^W = 0;
last
TODO;
}
sub
eq_array {
my
(
$ra
,
$rb
) =
@_
;
return
0
unless
$#$ra
==
$#$rb
;
for
my
$i
(0..
$#$ra
) {
next
if
!
defined
$ra
->[
$i
] && !
defined
$rb
->[
$i
];
return
0
if
!
defined
$ra
->[
$i
];
return
0
if
!
defined
$rb
->[
$i
];
return
0
unless
$ra
->[
$i
] eq
$rb
->[
$i
];
}
return
1;
}
sub
eq_hash {
my
(
$orig
,
$suspect
) =
@_
;
my
$fail
;
while
(
my
(
$key
,
$value
) =
each
%$suspect
) {
$key
=
""
.
$key
;
if
(
exists
$orig
->{
$key
}) {
if
(
$orig
->{
$key
} ne
$value
) {
print
STDOUT
"# key "
, _qq(
$key
),
" was "
, _qq(
$orig
->{
$key
}),
" now "
, _qq(
$value
),
"\n"
;
$fail
= 1;
}
}
else
{
print
STDOUT
"# key "
, _qq(
$key
),
" is "
, _qq(
$value
),
", not in original.\n"
;
$fail
= 1;
}
}
foreach
(
keys
%$orig
) {
$_
=
""
.
$_
;
next
if
(
exists
$suspect
->{
$_
});
print
STDOUT
"# key "
, _qq(
$_
),
" was "
, _qq(
$orig
->{
$_
}),
" now missing.\n"
;
$fail
= 1;
}
!
$fail
;
}
sub
require_ok ($) {
my
(
$require
) =
@_
;
eval
<<REQUIRE_OK;
require $require;
REQUIRE_OK
_ok(!$@, _where(),
"require $require"
);
}
sub
use_ok ($) {
my
(
$use
) =
@_
;
eval
<<USE_OK;
use $use;
USE_OK
_ok(!$@, _where(),
"use $use"
);
}
my
$is_mswin
= $^O eq
'MSWin32'
;
my
$is_netware
= $^O eq
'NetWare'
;
my
$is_macos
= $^O eq
'MacOS'
;
my
$is_vms
= $^O eq
'VMS'
;
sub
_quote_args {
my
(
$runperl
,
$args
) =
@_
;
foreach
(
@$args
) {
$_
=
q(")
.
$_
.
q(")
if
$is_vms
&& !/^\"/ &&
length
(
$_
) > 0;
$$runperl
.=
' '
.
$_
;
}
}
sub
_create_runperl {
my
%args
=
@_
;
my
$runperl
= $^X =~ m/\s/ ?
qq{"$^X"}
: $^X;
if
(
$ENV
{PERL_RUNPERL_DEBUG}) {
$runperl
=
"$ENV{PERL_RUNPERL_DEBUG} $runperl"
;
}
unless
(
$args
{nolib}) {
if
(
$is_macos
) {
$runperl
.=
' -I::lib'
;
$runperl
.=
' -MMac::err=unix'
if
$args
{stderr};
}
else
{
$runperl
.=
' "-I../lib"'
;
}
}
if
(
$args
{switches}) {
local
$Level
= 2;
die
"test.pl:runperl(): 'switches' must be an ARRAYREF "
. _where()
unless
ref
$args
{switches} eq
"ARRAY"
;
_quote_args(\
$runperl
,
$args
{switches});
}
if
(
defined
$args
{prog}) {
die
"test.pl:runperl(): both 'prog' and 'progs' cannot be used "
. _where()
if
defined
$args
{progs};
$args
{progs} = [
$args
{prog}]
}
if
(
defined
$args
{progs}) {
die
"test.pl:runperl(): 'progs' must be an ARRAYREF "
. _where()
unless
ref
$args
{progs} eq
"ARRAY"
;
foreach
my
$prog
(@{
$args
{progs}}) {
if
(
$is_mswin
||
$is_netware
||
$is_vms
) {
$runperl
.=
qq (
-e
"$prog"
);
}
else
{
$runperl
.=
qq (
-e
'$prog'
);
}
}
}
elsif
(
defined
$args
{progfile}) {
$runperl
.=
qq( "$args{progfile}")
;
}
else
{
die
"test.pl:runperl(): none of prog, progs, progfile, args, "
.
" switches or stdin specified"
unless
defined
$args
{args} or
defined
$args
{switches}
or
defined
$args
{stdin};
}
if
(
defined
$args
{stdin}) {
$args
{stdin} =~ s/\n/\\n/g;
$args
{stdin} =~ s/\r/\\r/g;
if
(
$is_mswin
||
$is_netware
||
$is_vms
) {
$runperl
=
qq{$^X -e "print qq(}
.
$args
{stdin} .
q{)" | }
.
$runperl
;
}
elsif
(
$is_macos
) {
my
$stdin
=
qq{$^X -e 'print qq(}
.
$args
{stdin} .
qq{)' > teststdin; }
;
if
(
$args
{verbose}) {
my
$stdindisplay
=
$stdin
;
$stdindisplay
=~ s/\n/\n\
print
STDERR
"# $stdindisplay\n"
;
}
`
$stdin
`;
$runperl
.=
q{ < teststdin }
;
}
else
{
$runperl
=
qq{$^X -e 'print qq(}
.
$args
{stdin} .
q{)' | }
.
$runperl
;
}
}
if
(
defined
$args
{args}) {
_quote_args(\
$runperl
,
$args
{args});
}
$runperl
.=
' 2>&1'
if
$args
{stderr} && !
$is_macos
;
$runperl
.=
" \xB3 Dev:Null"
if
!
$args
{stderr} &&
$is_macos
;
if
(
$args
{verbose}) {
my
$runperldisplay
=
$runperl
;
$runperldisplay
=~ s/\n/\n\
print
STDERR
"# $runperldisplay\n"
;
}
return
$runperl
;
}
sub
runperl {
die
"test.pl:runperl() does not take a hashref"
if
ref
$_
[0] and
ref
$_
[0] eq
'HASH'
;
my
$runperl
=
&_create_runperl
;
my
$result
;
my
$tainted
= ${^TAINT};
my
%args
=
@_
;
exists
$args
{switches} &&
grep
m/^-T$/, @{
$args
{switches}} and
$tainted
=
$tainted
+ 1;
if
(
$tainted
) {
my
$sep
;
eval
"require Config; Config->import"
;
if
($@) {
warn
"test.pl had problems loading Config: $@"
;
$sep
=
':'
;
}
else
{
$sep
=
$Config
{path_sep};
}
my
@keys
=
grep
{
exists
$ENV
{
$_
}}
qw(CDPATH IFS ENV BASH_ENV)
;
local
@ENV
{
@keys
} = ();
local
$ENV
{
'DCL$PATH'
} = $1
if
$is_vms
&& (
$ENV
{
'DCL$PATH'
} =~ /(.*)/s);
$ENV
{PATH} =~ /(.*)/s;
local
$ENV
{PATH} =
join
$sep
,
grep
{
$_
ne
""
and
$_
ne
"."
and
(
$is_mswin
or
$is_vms
or !(
stat
&& (
stat
_)[2]&0022)) }
split
quotemeta
(
$sep
), $1;
$runperl
=~ /(.*)/s;
$runperl
= $1;
$result
= `
$runperl
`;
}
else
{
$result
= `
$runperl
`;
}
$result
=~ s/\n\n/\n/
if
$is_vms
;
return
$result
;
}
*run_perl
= \
&runperl
;
sub
DIE {
print
STDERR
"# @_\n"
;
exit
1;
}
my
$Perl
;
sub
which_perl {
unless
(
defined
$Perl
) {
$Perl
= $^X;
return
$Perl
if
$^O eq
'VMS'
;
my
$exe
;
eval
"require Config; Config->import"
;
if
($@) {
warn
"test.pl had problems loading Config: $@"
;
$exe
=
''
;
}
else
{
$exe
=
$Config
{_exe};
}
$exe
=
''
unless
defined
$exe
;
if
(
$Perl
=~ /^perl\Q
$exe
\E$/i) {
my
$perl
=
"perl$exe"
;
eval
"require File::Spec"
;
if
($@) {
warn
"test.pl had problems loading File::Spec: $@"
;
$Perl
=
"./$perl"
;
}
else
{
$Perl
= File::Spec->catfile(File::Spec->curdir(),
$perl
);
}
}
if
(
$Perl
!~ /\Q
$exe
\E$/i) {
$Perl
.=
$exe
;
}
warn
"which_perl: cannot find $Perl from $^X"
unless
-f
$Perl
;
$ENV
{PERLEXE} =
$Perl
;
}
return
$Perl
;
}
sub
unlink_all {
foreach
my
$file
(
@_
) {
1
while
unlink
$file
;
print
STDERR
"# Couldn't unlink '$file': $!\n"
if
-f
$file
;
}
}
my
$tmpfile
=
"misctmp000"
;
1
while
-f ++
$tmpfile
;
END { unlink_all
$tmpfile
}
sub
_fresh_perl {
my
(
$prog
,
$resolve
,
$runperl_args
,
$name
) =
@_
;
$runperl_args
||= {};
$runperl_args
->{progfile} =
$tmpfile
;
$runperl_args
->{stderr} = 1;
open
TEST,
">$tmpfile"
or
die
"Cannot open $tmpfile: $!"
;
if
( $^O eq
'VMS'
) {
$prog
=~ s
$prog
=~ s{
if
\(-e _ and -f _ and -r _\)}
{
if
(-e _ and -f _)}
}
print
TEST
$prog
;
close
TEST or
die
"Cannot close $tmpfile: $!"
;
my
$results
= runperl(
%$runperl_args
);
my
$status
= $?;
$results
=~ s/\n+$//;
$results
=~ s/at\s+misctmp\d+\s+line/at - line/g;
$results
=~ s/of\s+misctmp\d+\s+aborted/of - aborted/g;
$results
=~ s/^(syntax|parse) error/syntax error/mig;
if
($^O eq
'VMS'
) {
$results
=~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
$results
=~ s/\n\n/\n/g;
}
my
$pass
=
$resolve
->(
$results
);
unless
(
$pass
) {
_diag
"# PROG: \n$prog\n"
;
_diag
"# EXPECTED:\n"
,
$resolve
->(),
"\n"
;
_diag
"# GOT:\n$results\n"
;
_diag
"# STATUS: $status\n"
;
}
unless
(
$name
) {
(
$first_line
,
$name
) =
$prog
=~ /^((.{1,50}).*)/;
$name
.=
'...'
if
length
$first_line
>
length
$name
;
}
_ok(
$pass
, _where(),
"fresh_perl - $name"
);
}
sub
fresh_perl_is {
my
(
$prog
,
$expected
,
$runperl_args
,
$name
) =
@_
;
local
$Level
= 2;
_fresh_perl(
$prog
,
sub
{
@_
?
$_
[0] eq
$expected
:
$expected
},
$runperl_args
,
$name
);
}
sub
fresh_perl_like {
my
(
$prog
,
$expected
,
$runperl_args
,
$name
) =
@_
;
local
$Level
= 2;
_fresh_perl(
$prog
,
sub
{
@_
?
$_
[0] =~ (
ref
$expected
?
$expected
: /
$expected
/) :
$expected
},
$runperl_args
,
$name
);
}
sub
can_ok ($@) {
my
(
$proto
,
@methods
) =
@_
;
my
$class
=
ref
$proto
||
$proto
;
unless
(
@methods
) {
return
_ok( 0, _where(),
"$class->can(...)"
);
}
my
@nok
= ();
foreach
my
$method
(
@methods
) {
local
($!, $@);
eval
{
$proto
->can(
$method
) } ||
push
@nok
,
$method
;
}
my
$name
;
$name
=
@methods
== 1 ?
"$class->can('$methods[0]')"
:
"$class->can(...)"
;
_ok( !
@nok
, _where(),
$name
);
}
sub
isa_ok ($$;$) {
my
(
$object
,
$class
,
$obj_name
) =
@_
;
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
{
local
($@, $!);
my
$rslt
=
eval
{
$object
->isa(
$class
) };
if
( $@ ) {
if
( $@ =~ /^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.
This should never happen. Please contact the author immediately.
Here's the error.
$@
WHOA
}
}
elsif
( !
$rslt
) {
my
$ref
=
ref
$object
;
$diag
=
"$obj_name isn't a '$class' it's a '$ref'"
;
}
}
_ok( !
$diag
, _where(),
$name
);
}
1;