sub
run {
my
(
$class
,
$file
) =
@_
;
$class
->new->from_file(
$file
)->test;
return
;
}
sub
new {
my
(
$class
,
@params
) =
@_
;
my
$self
=
$class
->SUPER::new(
@params
);
$self
->{count} = 0;
return
$self
;
}
sub
testml_begin {
my
(
$self
) =
@_
;
$self
->{checked} = 0;
$self
->{planned} = 0;
}
sub
testml_end {
my
(
$self
) =
@_
;
$self
->tap_done
unless
$self
->{planned};
}
sub
testml_eq {
my
(
$self
,
$got
,
$want
,
$label
,
$not
) =
@_
;
$self
->check_plan;
if
(not
$not
and
$got
ne
$want
and
$want
=~ /\n/ and
(not
defined
$self
->getv(
'Diff'
) or
$self
->getv(
'Diff'
)) and
not(
$ENV
{TESTML_NO_DIFF}) and
) {
$self
->tap_ok(0,
$label
? (
$label
) : ());
my
$diff
= Text::Diff::diff(
\
$want
,
\
$got
,
{
FILENAME_A
=>
'want'
,
FILENAME_B
=>
'got'
,
}
);
$self
->tap_diag(
$diff
);
}
elsif
(
$not
) {
$self
->tap_isnt(
$got
,
$want
,
$label
? (
$label
) : ());
}
else
{
$self
->tap_is(
$got
,
$want
,
$label
? (
$label
) : ());
}
}
sub
testml_like {
my
(
$self
,
$got
,
$want
,
$label
,
$not
) =
@_
;
$self
->check_plan;
if
(
$not
) {
$self
->tap_unlike(
$got
,
$want
,
$label
);
}
else
{
$self
->tap_like(
$got
,
$want
,
$label
);
}
}
sub
testml_has {
my
(
$self
,
$got
,
$want
,
$label
,
$not
) =
@_
;
$self
->check_plan;
my
$index
=
index
(
$got
,
$want
);
if
(
$not
? (
$index
== -1) : (
$index
!= -1)) {
$self
->tap_ok(1,
$label
);
}
else
{
$self
->tap_ok(0,
$label
);
my
$verb
=
$not
?
' does'
:
"doesn't"
;
$self
->tap_diag(
" this string: '$got'\n $verb contain: '$want'"
);
}
}
sub
testml_list_has {
my
(
$self
,
$got
,
$want
,
$label
) =
@_
;
$self
->check_plan;
for
my
$str
(
@$got
) {
next
if
ref
$str
;
if
(
$str
eq
$want
) {
$self
->tap_ok(1,
$label
);
return
;
}
}
$self
->tap_ok(0,
$label
);
$self
->tap_diag(
" this list: @$got\n doesn't contain: $want"
);
}
sub
check_plan {
my
(
$self
) =
@_
;
return
if
$self
->{checked};
$self
->{checked} = 1;
if
(
my
$plan
=
$self
->{vars}{Plan}) {
$self
->{planned} = 1;
$self
->tap_plan(
$plan
);
}
}
sub
tap_plan {
my
(
$self
,
$plan
) =
@_
;
$self
->out(
"1..$plan"
);
}
sub
tap_pass {
my
(
$self
,
$label
) =
@_
;
$label
=
''
unless
defined
$label
;
$label
=
" - $label"
if
$label
;
$self
->out(
"ok ${\ ++$self->{count}}$label"
);
return
;
}
sub
tap_fail {
my
(
$self
,
$label
) =
@_
;
$label
=
''
unless
defined
$label
;
$label
=
" - $label"
if
$label
;
$self
->out(
"not ok ${\ ++$self->{count}}$label"
);
return
;
}
sub
tap_ok {
my
(
$self
,
$ok
,
$label
) =
@_
;
if
(
$ok
) {
$self
->tap_pass(
$label
);
}
else
{
$self
->tap_fail(
$label
);
}
}
sub
tap_is {
my
(
$self
,
$got
,
$want
,
$label
) =
@_
;
my
$ok
=
$got
eq
$want
;
if
(
$ok
) {
$self
->tap_pass(
$label
);
}
else
{
$self
->tap_fail(
$label
);
$self
->show_error(
' got:'
,
$got
,
' expected:'
,
$want
,
$label
,
);
}
}
sub
tap_isnt {
my
(
$self
,
$got
,
$want
,
$label
) =
@_
;
my
$ok
=
$got
ne
$want
;
if
(
$ok
) {
$self
->tap_pass(
$label
);
}
else
{
$self
->tap_fail(
$label
);
$self
->show_error(
' got:'
,
$got
,
' expected:'
,
'anything else'
,
$label
,
);
}
}
sub
tap_like {
my
(
$self
,
$got
,
$want
,
$label
) =
@_
;
if
(
$got
=~
$want
) {
$self
->tap_pass(
$label
);
}
else
{
$self
->tap_fail(
$label
);
}
}
sub
tap_unlike {
my
(
$self
,
$got
,
$want
,
$label
) =
@_
;
if
(
$got
!~
$want
) {
$self
->tap_pass(
$label
);
}
else
{
$self
->tap_fail(
$label
);
}
}
sub
tap_diag {
my
(
$self
,
$msg
) =
@_
;
my
$str
=
$msg
;
$str
=~ s/^/
$self
->err(
$str
);
}
sub
tap_done {
my
(
$self
) =
@_
;
$self
->out(
"1..${\ $self->{count}}"
);
}
sub
show_error {
my
(
$self
,
$got_prefix
,
$got
,
$want_prefix
,
$want
,
$label
) =
@_
;
if
(
$label
) {
$self
->err(
"# Failed test '$label'"
);
}
else
{
$self
->err(
"# Failed test"
);
}
if
(not
ref
$got
) {
$got
=
"'$got'"
}
$self
->tap_diag(
"$got_prefix $got"
);
if
(not
ref
$want
) {
$want
=
"'$want'"
}
$self
->tap_diag(
"$want_prefix $want"
);
}
sub
out {
my
(
$self
,
$str
) =
@_
;
local
$| = 1;
binmode
STDOUT,
':utf8'
;
print
STDOUT
"$str$/"
;
}
sub
err {
my
(
$self
,
$str
) =
@_
;
binmode
STDERR,
':utf8'
;
print
STDERR
"$str$/"
;
}
1;