my
$perldoc_data
=
<<'END_PERLDOC';
=config head1 :numbered
=config head2 :numbered
=config head3 :!numbered
=head1 The Problem
=head1 The Solution
=head2 Analysis
=head3 Overview
=head3 Details
=head2 Design
=head1 The Implementation
END_PERLDOC
my
$expected_structure
=
eval
<<'END_EXPECTED';
$VAR1 = bless( {
'warnings' => [],
'errors' => [],
'tree' => bless( {
'typename' => '(document)',
'content' => [
bless( {
'typename' => 'pod',
'content' => [
bless( {
'typename' => 'config',
'number' => '1',
'content' => [
undef
],
'style' => 'directive',
'target' => 'head1'
}, 'Perl6::Perldoc::Directive::config' ),
bless( {
'typename' => 'config',
'number' => '2',
'content' => [
undef
],
'style' => 'directive',
'target' => 'head2'
}, 'Perl6::Perldoc::Directive::config' ),
bless( {
'typename' => 'config',
'target' => 'head3',
'content' => [
undef
],
'style' => 'directive'
}, 'Perl6::Perldoc::Directive::config' ),
bless( {
'typename' => 'head1',
'number' => '1',
'content' => [
'The Problem
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::head1' ),
bless( {
'typename' => 'head1',
'number' => '2',
'content' => [
'The Solution
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::head1' ),
bless( {
'typename' => 'head2',
'number' => '2.1',
'content' => [
'Analysis
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::head2' ),
bless( {
'typename' => 'head3',
'content' => [
'Overview
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::head3' ),
bless( {
'typename' => 'head3',
'content' => [
'Details
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::head3' ),
bless( {
'typename' => 'head2',
'number' => '2.2',
'content' => [
'Design
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::head2' ),
bless( {
'typename' => 'head1',
'number' => '3',
'content' => [
'The Implementation
'
],
'style' => 'abbreviated'
}, 'Perl6::Perldoc::Block::head1' )
],
'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"
;
}
}