use
5.006001;
our
$VERSION
=
'0.59'
;
my
@test_more_exports
;
BEGIN {
@test_more_exports
=
qw(
ok isnt like unlike is_deeply cmp_ok
skip todo_skip pass fail
eq_array eq_hash eq_set
plan can_ok isa_ok diag
use_ok
$TODO
)
;
}
our
@EXPORT
= (
@test_more_exports
,
qw(
is no_diff
blocks next_block first_block
delimiters spec_file spec_string
filters filters_delay filter_arguments
run run_compare run_is run_is_deeply run_like run_unlike
skip_all_unless_require is_deep run_is_deep
WWW XXX YYY ZZZ
tie_output no_diag_on_only
find_my_self default_object
croak carp cluck confess
)
);
field
'_spec_file'
;
field
'_spec_string'
;
field
_filters
=> [
qw(norm trim)
];
field
_filters_map
=> {};
field
spec
=>
-init
=>
'$self->_spec_init'
;
field
block_list
=>
-init
=>
'$self->_block_list_init'
;
field
_next_list
=> [];
field
block_delim
=>
-init
=>
'$self->block_delim_default'
;
field
data_delim
=>
-init
=>
'$self->data_delim_default'
;
field
_filters_delay
=> 0;
field
_no_diag_on_only
=> 0;
field
block_delim_default
=>
'==='
;
field
data_delim_default
=>
'---'
;
my
$default_class
;
my
$default_object
;
my
$reserved_section_names
= {};
sub
default_object {
$default_object
||=
$default_class
->new;
return
$default_object
;
}
my
$import_called
= 0;
sub
import
() {
$import_called
= 1;
my
$class
= (
grep
/^-base$/i,
@_
)
?
scalar
(
caller
)
:
$_
[0];
if
(not
defined
$default_class
) {
$default_class
=
$class
;
}
unless
(
grep
/^-base$/i,
@_
) {
my
@args
;
for
(
my
$ii
= 1;
$ii
<=
$#_
; ++
$ii
) {
if
(
$_
[
$ii
] eq
'-package'
) {
++
$ii
;
}
else
{
push
@args
,
$_
[
$ii
];
}
}
Test::More->
import
(
import
=> \
@test_more_exports
,
@args
)
if
@args
;
}
_strict_warnings();
goto
&Spiffy::import
;
}
my
$plan_code
= \
&Test::Builder::plan
;
my
$Have_Plan
= 0;
{
no
warnings
'redefine'
;
*Test::Builder::plan
=
sub
{
$Have_Plan
= 1;
goto
&$plan_code
;
};
}
my
$DIED
= 0;
$SIG
{__DIE__} =
sub
{
$DIED
= 1;
die
@_
};
sub
block_class {
$self
->find_class(
'Block'
) }
sub
filter_class {
$self
->find_class(
'Filter'
) }
sub
find_class {
my
$suffix
=
shift
;
my
$class
=
ref
(
$self
) .
"::$suffix"
;
return
$class
if
$class
->can(
'new'
);
$class
= __PACKAGE__ .
"::$suffix"
;
return
$class
if
$class
->can(
'new'
);
eval
"require $class"
;
return
$class
if
$class
->can(
'new'
);
die
"Can't find a class for $suffix"
;
}
sub
check_late {
if
(
$self
->{block_list}) {
my
$caller
= (
caller
(1))[3];
$caller
=~ s/.*:://;
croak
"Too late to call $caller()"
}
}
sub
find_my_self() {
my
$self
=
ref
(
$_
[0]) eq
$default_class
?
splice
(
@_
, 0, 1)
: default_object();
return
$self
,
@_
;
}
sub
blocks() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
croak
"Invalid arguments passed to 'blocks'"
if
@_
> 1;
croak
sprintf
(
"'%s' is invalid argument to blocks()"
,
shift
(
@_
))
if
@_
&&
$_
[0] !~ /^[a-zA-Z]\w*$/;
my
$blocks
=
$self
->block_list;
my
$section_name
=
shift
||
''
;
my
@blocks
=
$section_name
? (
grep
{
exists
$_
->{
$section_name
} }
@$blocks
)
: (
@$blocks
);
return
scalar
(
@blocks
)
unless
wantarray
;
return
(
@blocks
)
if
$self
->_filters_delay;
for
my
$block
(
@blocks
) {
$block
->run_filters
unless
$block
->is_filtered;
}
return
(
@blocks
);
}
sub
next_block() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
my
$list
=
$self
->_next_list;
if
(
@$list
== 0) {
$list
= [@{
$self
->block_list},
undef
];
$self
->_next_list(
$list
);
}
my
$block
=
shift
@$list
;
if
(
defined
$block
and not
$block
->is_filtered) {
$block
->run_filters;
}
return
$block
;
}
sub
first_block() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
$self
->_next_list([]);
$self
->next_block;
}
sub
filters_delay() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
$self
->_filters_delay(
defined
$_
[0] ?
shift
: 1);
}
sub
no_diag_on_only() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
$self
->_no_diag_on_only(
defined
$_
[0] ?
shift
: 1);
}
sub
delimiters() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
$self
->check_late;
my
(
$block_delimiter
,
$data_delimiter
) =
@_
;
$block_delimiter
||=
$self
->block_delim_default;
$data_delimiter
||=
$self
->data_delim_default;
$self
->block_delim(
$block_delimiter
);
$self
->data_delim(
$data_delimiter
);
return
$self
;
}
sub
spec_file() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
$self
->check_late;
$self
->_spec_file(
shift
);
return
$self
;
}
sub
spec_string() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
$self
->check_late;
$self
->_spec_string(
shift
);
return
$self
;
}
sub
filters() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
if
(
ref
(
$_
[0]) eq
'HASH'
) {
$self
->_filters_map(
shift
);
}
else
{
my
$filters
=
$self
->_filters;
push
@$filters
,
@_
;
}
return
$self
;
}
sub
filter_arguments() {
$Test::Base::Filter::arguments
;
}
sub
have_text_diff {
$Text::Diff::VERSION
>= 0.35 &&
$Algorithm::Diff::VERSION
>= 1.15;
}
sub
is($$;$) {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
my
(
$actual
,
$expected
,
$name
) =
@_
;
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
if
(
$ENV
{TEST_SHOW_NO_DIFFS} or
not
defined
$actual
or
not
defined
$expected
or
$actual
eq
$expected
or
not(
$self
->have_text_diff) or
$expected
!~ /\n./s
) {
Test::More::is(
$actual
,
$expected
,
$name
);
}
else
{
$name
=
''
unless
defined
$name
;
ok
$actual
eq
$expected
,
$name
.
"\n"
. Text::Diff::diff(\
$expected
, \
$actual
);
}
}
sub
run(&;$) {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
my
$callback
=
shift
;
for
my
$block
(@{
$self
->block_list}) {
$block
->run_filters
unless
$block
->is_filtered;
&{
$callback
}(
$block
);
}
}
my
$name_error
=
"Can't determine section names"
;
sub
_section_names {
return
@_
if
@_
== 2;
my
$block
=
$self
->first_block
or croak
$name_error
;
my
@names
=
grep
{
$_
!~ /^(ONLY|LAST|SKIP)$/;
} @{
$block
->{_section_order}[0] || []};
croak
"$name_error. Need two sections in first block"
unless
@names
== 2;
return
@names
;
}
sub
_assert_plan {
plan(
'no_plan'
)
unless
$Have_Plan
;
}
sub
END {
run_compare()
unless
$Have_Plan
or
$DIED
or not
$import_called
;
}
sub
run_compare() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
$self
->_assert_plan;
my
(
$x
,
$y
) =
$self
->_section_names(
@_
);
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
for
my
$block
(@{
$self
->block_list}) {
next
unless
exists
(
$block
->{
$x
}) and
exists
(
$block
->{
$y
});
$block
->run_filters
unless
$block
->is_filtered;
if
(
ref
$block
->
$x
) {
is_deeply(
$block
->
$x
,
$block
->
$y
,
$block
->name ?
$block
->name : ());
}
elsif
(
ref
$block
->
$y
eq
'Regexp'
) {
my
$regexp
=
ref
$y
?
$y
:
$block
->
$y
;
like(
$block
->
$x
,
$regexp
,
$block
->name ?
$block
->name : ());
}
else
{
is(
$block
->
$x
,
$block
->
$y
,
$block
->name ?
$block
->name : ());
}
}
}
sub
run_is() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
$self
->_assert_plan;
my
(
$x
,
$y
) =
$self
->_section_names(
@_
);
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
for
my
$block
(@{
$self
->block_list}) {
next
unless
exists
(
$block
->{
$x
}) and
exists
(
$block
->{
$y
});
$block
->run_filters
unless
$block
->is_filtered;
is(
$block
->
$x
,
$block
->
$y
,
$block
->name ?
$block
->name : ()
);
}
}
sub
run_is_deeply() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
$self
->_assert_plan;
my
(
$x
,
$y
) =
$self
->_section_names(
@_
);
for
my
$block
(@{
$self
->block_list}) {
next
unless
exists
(
$block
->{
$x
}) and
exists
(
$block
->{
$y
});
$block
->run_filters
unless
$block
->is_filtered;
is_deeply(
$block
->
$x
,
$block
->
$y
,
$block
->name ?
$block
->name : ()
);
}
}
sub
run_like() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
$self
->_assert_plan;
my
(
$x
,
$y
) =
$self
->_section_names(
@_
);
for
my
$block
(@{
$self
->block_list}) {
next
unless
exists
(
$block
->{
$x
}) and
defined
(
$y
);
$block
->run_filters
unless
$block
->is_filtered;
my
$regexp
=
ref
$y
?
$y
:
$block
->
$y
;
like(
$block
->
$x
,
$regexp
,
$block
->name ?
$block
->name : ()
);
}
}
sub
run_unlike() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
$self
->_assert_plan;
my
(
$x
,
$y
) =
$self
->_section_names(
@_
);
for
my
$block
(@{
$self
->block_list}) {
next
unless
exists
(
$block
->{
$x
}) and
defined
(
$y
);
$block
->run_filters
unless
$block
->is_filtered;
my
$regexp
=
ref
$y
?
$y
:
$block
->
$y
;
unlike(
$block
->
$x
,
$regexp
,
$block
->name ?
$block
->name : ()
);
}
}
sub
skip_all_unless_require() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
my
$module
=
shift
;
eval
"require $module; 1"
or Test::More::plan(
skip_all
=>
"$module failed to load"
);
}
sub
is_deep() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
Test::Deep::cmp_deeply(
@_
);
}
sub
run_is_deep() {
(
my
(
$self
),
@_
) = find_my_self(
@_
);
$self
->_assert_plan;
my
(
$x
,
$y
) =
$self
->_section_names(
@_
);
for
my
$block
(@{
$self
->block_list}) {
next
unless
exists
(
$block
->{
$x
}) and
exists
(
$block
->{
$y
});
$block
->run_filters
unless
$block
->is_filtered;
is_deep(
$block
->
$x
,
$block
->
$y
,
$block
->name ?
$block
->name : ()
);
}
}
sub
_pre_eval {
my
$spec
=
shift
;
return
$spec
unless
$spec
=~
s/\A\s*<<<(.*?)>>>\s*$//sm;
my
$eval_code
= $1;
eval
"package main; $eval_code"
;
croak $@
if
$@;
return
$spec
;
}
sub
_block_list_init {
my
$spec
=
$self
->spec;
$spec
=
$self
->_pre_eval(
$spec
);
my
$cd
=
$self
->block_delim;
my
@hunks
= (
$spec
=~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg);
my
$blocks
=
$self
->_choose_blocks(
@hunks
);
$self
->block_list(
$blocks
);
my
$seq
= 1;
for
my
$block
(
@$blocks
) {
$block
->blocks_object(
$self
);
$block
->seq_num(
$seq
++);
}
return
$blocks
;
}
sub
_choose_blocks {
my
$blocks
= [];
for
my
$hunk
(
@_
) {
my
$block
=
$self
->_make_block(
$hunk
);
if
(
exists
$block
->{ONLY}) {
diag
"I found ONLY: maybe you're debugging?"
unless
$self
->_no_diag_on_only;
return
[
$block
];
}
next
if
exists
$block
->{SKIP};
push
@$blocks
,
$block
;
if
(
exists
$block
->{LAST}) {
return
$blocks
;
}
}
return
$blocks
;
}
sub
_check_reserved {
my
$id
=
shift
;
croak
"'$id' is a reserved name. Use something else.\n"
if
$reserved_section_names
->{
$id
} or
$id
=~ /^_/;
}
sub
_make_block {
my
$hunk
=
shift
;
my
$cd
=
$self
->block_delim;
my
$dd
=
$self
->data_delim;
my
$block
=
$self
->block_class->new;
$hunk
=~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or
die
;
my
$name
= $1;
my
@parts
=
split
/^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m,
$hunk
;
my
$description
=
shift
@parts
;
$description
||=
''
;
unless
(
$description
=~ /\S/) {
$description
=
$name
;
}
$description
=~ s/\s*\z//;
$block
->set_value(
description
=>
$description
);
my
$section_map
= {};
my
$section_order
= [];
while
(
@parts
) {
my
(
$type
,
$filters
,
$value
) =
splice
(
@parts
, 0, 3);
$self
->_check_reserved(
$type
);
$value
=
''
unless
defined
$value
;
$filters
=
''
unless
defined
$filters
;
if
(
$filters
=~ /:(\s|\z)/) {
croak
"Extra lines not allowed in '$type' section"
if
$value
=~ /\S/;
(
$filters
,
$value
) =
split
/\s*:(?:\s+|\z)/,
$filters
, 2;
$value
=
''
unless
defined
$value
;
$value
=~ s/^\s*(.*?)\s*$/$1/;
}
$section_map
->{
$type
} = {
filters
=>
$filters
,
};
push
@$section_order
,
$type
;
$block
->set_value(
$type
,
$value
);
}
$block
->set_value(
name
=>
$name
);
$block
->set_value(
_section_map
=>
$section_map
);
$block
->set_value(
_section_order
=>
$section_order
);
return
$block
;
}
sub
_spec_init {
return
$self
->_spec_string
if
$self
->_spec_string;
local
$/;
my
$spec
;
if
(
my
$spec_file
=
$self
->_spec_file) {
open
FILE,
$spec_file
or
die
$!;
$spec
= <FILE>;
close
FILE;
}
else
{
$spec
=
do
{
no
warnings
'once'
;
<DATA>;
};
}
return
$spec
;
}
sub
_strict_warnings() {
my
$done
= 0;
Filter::Util::Call::filter_add(
sub
{
return
0
if
$done
;
my
(
$data
,
$end
) = (
''
,
''
);
while
(
my
$status
= Filter::Util::Call::filter_read()) {
return
$status
if
$status
< 0;
if
(/^__(?:END|DATA)__\r?$/) {
$end
=
$_
;
last
;
}
$data
.=
$_
;
$_
=
''
;
}
$_
=
"use strict;use warnings;$data$end"
;
$done
= 1;
}
);
}
sub
tie_output() {
my
$handle
=
shift
;
die
"No buffer to tie"
unless
@_
;
tie
$handle
,
'Test::Base::Handle'
,
$_
[0];
}
sub
no_diff {
$ENV
{TEST_SHOW_NO_DIFFS} = 1;
}
sub
TIEHANDLE() {
my
$class
=
shift
;
bless
\
$_
[0],
$class
;
}
sub
PRINT {
$$self
.=
$_
for
@_
;
}
our
@ISA
=
qw(Spiffy)
;
our
@EXPORT
=
qw(block_accessor)
;
sub
AUTOLOAD {
return
;
}
sub
block_accessor() {
my
$accessor
=
shift
;
no
strict
'refs'
;
return
if
defined
&$accessor
;
*$accessor
=
sub
{
my
$self
=
shift
;
if
(
@_
) {
Carp::croak
"Not allowed to set values for '$accessor'"
;
}
my
@list
= @{
$self
->{
$accessor
} || []};
return
wantarray
? (
@list
)
:
$list
[0];
};
}
block_accessor
'name'
;
block_accessor
'description'
;
Spiffy::field
'seq_num'
;
Spiffy::field
'is_filtered'
;
Spiffy::field
'blocks_object'
;
Spiffy::field
'original_values'
=> {};
sub
set_value {
no
strict
'refs'
;
my
$accessor
=
shift
;
block_accessor
$accessor
unless
defined
&$accessor
;
$self
->{
$accessor
} = [
@_
];
}
sub
run_filters {
my
$map
=
$self
->_section_map;
my
$order
=
$self
->_section_order;
Carp::croak
"Attempt to filter a block twice"
if
$self
->is_filtered;
for
my
$type
(
@$order
) {
my
$filters
=
$map
->{
$type
}{filters};
my
@value
=
$self
->
$type
;
$self
->original_values->{
$type
} =
$value
[0];
for
my
$filter
(
$self
->_get_filters(
$type
,
$filters
)) {
$Test::Base::Filter::arguments
=
$filter
=~ s/=(.*)$// ? $1 :
undef
;
my
$function
=
"main::$filter"
;
no
strict
'refs'
;
if
(
defined
&$function
) {
local
$_
=
(
@value
== 1 and not
defined
(
$value
[0])) ?
undef
:
join
''
,
@value
;
my
$old
=
$_
;
@value
=
&$function
(
@value
);
if
(not(
@value
) or
@value
== 1 and
defined
(
$value
[0]) and
$value
[0] =~ /\A(\d+|)\z/
) {
if
(
$value
[0] &&
$_
eq
$old
) {
Test::Base::diag(
"Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't."
);
}
@value
= (
$_
);
}
}
else
{
my
$filter_object
=
$self
->blocks_object->filter_class->new;
die
"Can't find a function or method for '$filter' filter\n"
unless
$filter_object
->can(
$filter
);
$filter_object
->current_block(
$self
);
@value
=
$filter_object
->
$filter
(
@value
);
}
$self
->set_value(
$type
,
@value
);
}
}
$self
->is_filtered(1);
}
sub
_get_filters {
my
$type
=
shift
;
my
$string
=
shift
||
''
;
$string
=~ s/\s*(.*?)\s*/$1/;
my
@filters
= ();
my
$map_filters
=
$self
->blocks_object->_filters_map->{
$type
} || [];
$map_filters
= [
$map_filters
]
unless
ref
$map_filters
;
my
@append
= ();
for
(
@{
$self
->blocks_object->_filters},
@$map_filters
,
split
(/\s+/,
$string
),
) {
my
$filter
=
$_
;
last
unless
length
$filter
;
if
(
$filter
=~ s/^-//) {
@filters
=
grep
{
$_
ne
$filter
}
@filters
;
}
elsif
(
$filter
=~ s/^\+//) {
push
@append
,
$filter
;
}
else
{
push
@filters
,
$filter
;
}
}
return
@filters
,
@append
;
}
{
%$reserved_section_names
=
map
{
(
$_
, 1);
}
keys
(
%Test::Base::Block::
),
qw( new DESTROY )
;
}