my
$perldoc_data
=
<<'END_PERLDOC';
The options are:
=item1 # Liberty
=item1 # Death
=item1 # Beer
The tools are:
=item1 # Revolution
=item1 # Deep-fried peanut butter sandwich
=item1 # Keg
END_PERLDOC
my
$expected_structure
=
eval
<<'END_EXPECTED';
$VAR1 = bless( {
'warnings' => [],
'errors' => [],
'tree' => bless( {
'typename' => '(document)',
'content' => [
bless( {
'typename' => 'pod',
'content' => [
bless( {
'typename' => 'para',
'content' => [
'The options are:
'
],
'style' => 'implicit'
}, 'Perl6::Perldoc::Block::para' ),
bless( {
'typename' => 'list',
'content' => [
bless( {
'typename' => 'item1',
'number' => '1',
'content' => [
'Liberty
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::item1' ),
bless( {
'typename' => 'item1',
'number' => '2',
'content' => [
'Death
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::item1' ),
bless( {
'typename' => 'item1',
'number' => '3',
'content' => [
'Beer
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::item1' )
],
'style' => 'implicit'
}, 'Perl6::Perldoc::Block::list' ),
bless( {
'typename' => 'para',
'content' => [
'The tools are:
'
],
'style' => 'implicit'
}, 'Perl6::Perldoc::Block::para' ),
bless( {
'typename' => 'list',
'content' => [
bless( {
'typename' => 'item1',
'number' => '1',
'content' => [
'Revolution
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::item1' ),
bless( {
'typename' => 'item1',
'number' => '2',
'content' => [
'Deep-fried peanut butter sandwich
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::item1' ),
bless( {
'typename' => 'item1',
'number' => '3',
'content' => [
'Keg
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::item1' )
],
'style' => 'implicit'
}, 'Perl6::Perldoc::Block::list' )
],
'style' => 'implicit'
}, 'Perl6::Perldoc::Block::pod' )
]
}, 'Perl6::Perldoc::Document' )
}, 'Perl6::Perldoc::Parser::ReturnVal' );
END_EXPECTED
for
my
$msg
( @{
$expected_structure
->{warnings} },
@{
$expected_structure
->{errors} }
) {
$msg
=~ s{at \S+ line}{at line};
}
open
my
$fh
,
'<'
, \
$perldoc_data
or
die
"Could not open file on test data"
;
my
$representation
= Perl6::Perldoc::Parser->parse(
$fh
,{
all_pod
=>1});
compare(
' '
,
'return value'
,
{%{
$representation
}},
{%{
$expected_structure
}}
);
my
%is_valid_scalar_method
;
my
%is_valid_list_method
;
BEGIN {
@is_valid_scalar_method
{
qw< typename style number target >
} = ();
@is_valid_list_method
{
qw< content rows cells >
} = ();
}
sub
compare {
my
(
$indent
,
$desc
,
$rep
,
$expected
) =
@_
;
my
(
$rep_class
,
$expected_class
)
=
map
{
ref
(
$_
) ||
q{STRING}
}
$rep
,
$expected
;
is
$rep_class
,
$expected_class
=>
"$indent$desc is $expected_class"
;
$indent
.=
q{ }
;
my
$expected_type
= reftype(
$expected
) ||
q{STRING}
;
if
(blessed
$expected
) {
for
my
$attr
(
keys
%{
$expected
} ) {
my
$is_scalar
=
exists
$is_valid_scalar_method
{
$attr
};
my
$is_list
=
exists
$is_valid_list_method
{
$attr
};
if
(!
$is_scalar
&& !
$is_list
) {
fail
"Internal error: unknown method $attr() "
.
"expected for $rep_class node"
;
}
elsif
(!
$rep
->can(
$attr
) ) {
fail
"Can't call $attr() on $rep_class node"
;
}
elsif
(
$is_list
) {
compare(
$indent
,
$attr
, [
$rep
->
$attr
],
$expected
->{
$attr
});
}
else
{
compare(
$indent
,
$attr
,
scalar
(
$rep
->
$attr
),
$expected
->{
$attr
});
}
}
}
elsif
(
$expected_type
eq
'HASH'
) {
for
my
$attr
(
keys
%{
$expected
} ) {
compare(
$indent
,
$attr
,
$rep
->{
$attr
},
$expected
->{
$attr
});
}
}
elsif
(
$expected_type
eq
'ARRAY'
) {
for
my
$idx
( 0..$
compare(
$indent
,
"[$idx]"
,
$rep
->[
$idx
],
$expected
->[
$idx
]);
}
}
else
{
is
$rep
,
$expected
=>
"$indent$desc content was correct"
;
}
}