has
"_p_rd"
=> (
'isa'
=>
"Parse::RecDescent"
,
is
=>
"rw"
);
sub
_init
{
my
$self
=
shift
;
$self
->_p_rd(Parse::RecDescent->new(
$self
->_calc_grammar()));
return
0;
}
sub
_calc_grammar
{
my
$self
=
shift
;
return
<<'EOF';
start : tag {$thisparser->{ret} = $item[1]; 1 }
text_unit: tag_or_comment { $item[1] }
| speech_or_desc { $item[1] }
tag_or_comment: tag
| comment
comment: /<!--(.*?)-->/ms para_sep {
XML::Grammar::Fiction::FromProto::Node::Comment->new(
text => $1
)
}
para_sep: /(\n\s*)+/
speech_or_desc: speech_unit
| desc_unit
plain_inner_text: /([^\n<\[\]&]+\n?)+/ { $item[1] }
inner_standalone_tag: /</ id attribute(s?) / *\/ *>/ space
{
XML::Grammar::Fiction::FromProto::Node::Element->new(
name => $item[2],
children => XML::Grammar::Fiction::FromProto::Node::List->new(
contents => []
),
attrs => $item[3]
);
}
inner_tag: opening_tag inner_text closing_tag {
my ($open, $inside, $close) = @item[1..$#item];
if ($open->{name} ne $close->{name})
{
Carp::confess("Tags do not match: $open->{name} and $close->{name}");
}
XML::Grammar::Fiction::FromProto::Node::Element->new(
name => $open->{name},
children => XML::Grammar::Fiction::FromProto::Node::List->new(
contents => $inside
),
attrs => $open->{attrs},
)
}
inner_desc: /\[/ inner_text /\]/ {
my $inside = $item[2];
XML::Grammar::Fiction::FromProto::Node::InnerDesc->new(
children => XML::Grammar::Fiction::FromProto::Node::List->new(
contents => $inside
),
)
}
inner_tag_or_desc: inner_tag
| inner_desc
inner_entity: /\&\w+;/ {
my $inside = $item[1];
HTML::Entities::decode_entities($inside)
}
inner_text_unit: plain_inner_text { [ $item[1] ] }
| inner_tag_or_desc { [ $item[1] ] }
| inner_entity { [ $item[1] ] }
| inner_standalone_tag { [ $item[1] ] }
inner_text: inner_text_unit(s) {
[ map { @{$_} } @{$item[1]} ]
}
addressing: /^([^:\n\+]+): /ms { $1 }
saying_first_para: addressing inner_text para_sep {
my ($sayer, $what) = ($item[1], $item[2]);
+{
character => $sayer,
para => XML::Grammar::Fiction::FromProto::Node::Paragraph->new(
children =>
XML::Grammar::Fiction::FromProto::Node::List->new(
contents => $what,
)
),
}
}
saying_other_para: /^\++: /ms inner_text para_sep {
XML::Grammar::Fiction::FromProto::Node::Paragraph->new(
children =>
XML::Grammar::Fiction::FromProto::Node::List->new(
contents => $item[2],
),
)
}
speech_unit: saying_first_para saying_other_para(s?)
{
my $first = $item[1];
my $others = $item[2] || [];
XML::Grammar::Fiction::FromProto::Node::Saying->new(
character => $first->{character},
children => XML::Grammar::Fiction::FromProto::Node::List->new(
contents => [ $first->{para}, @{$others} ],
),
)
}
desc_para: inner_text para_sep { $item[1] }
desc_unit_inner: desc_para(s?) inner_text { [ @{$item[1]}, $item[2] ] }
desc_unit: /^\[/ms desc_unit_inner /\]\s*$/ms para_sep {
my $paragraphs = $item[2];
XML::Grammar::Fiction::FromProto::Node::Description->new(
children =>
XML::Grammar::Fiction::FromProto::Node::List->new(
contents =>
[
map {
XML::Grammar::Fiction::FromProto::Node::Paragraph->new(
children =>
XML::Grammar::Fiction::FromProto::Node::List->new(
contents => $_,
),
)
} @$paragraphs
],
),
)
}
text: text_unit(s) { XML::Grammar::Fiction::FromProto::Node::List->new(
contents => $item[1]
) }
| space { XML::Grammar::Fiction::FromProto::Node::List->new(
contents => []
) }
tag: space opening_tag space text space closing_tag space
{
my (undef, $open, undef, $inside, undef, $close) = @item[1..$#item];
if ($open->{name} ne $close->{name})
{
Carp::confess("Tags do not match: $open->{name} and $close->{name}");
}
XML::Grammar::Fiction::FromProto::Node::Element->new(
name => $open->{name},
children => $inside,
attrs => $open->{attrs},
);
}
opening_tag: '<' id attribute(s?) '>'
{ $item[0] = { 'name' => $item[2], 'attrs' => $item[3] }; }
closing_tag: '</' id '>'
{ $item[0] = { 'name' => $item[2], }; }
attribute: space id '="' attributevalue '"' space
{ $item[0] = { 'key' => $item[2] , 'value' => $item[4] }; }
attributevalue: /[^"]+/
{ $item[0] = HTML::Entities::decode_entities($item[1]); }
space: /\s*/
id: /[a-zA-Z_\-]+/
EOF
}
sub
process_text
{
my
(
$self
,
$text
) =
@_
;
my
$rv
=
$self
->_p_rd()->start(
$text
);
if
(!
defined
(
$rv
))
{
return
;
}
else
{
return
$self
->_p_rd->{ret};
}
}
1;