use strict;
use Moose;
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;
=head1 NAME
XML::Grammar::Fiction::FromProto::Parser - base class for parsers of the
ScreenplayXML proto-text.
B<For internal use only>.
=head1 METHODS
=head2 $self->process_text($string)
Processes the text and returns it.
=head2 $self->meta()
Something that L<Moose> adds.
=head1 AUTHOR
=head1 BUGS
Please report any bugs or feature requests to
C<bug-xml-grammar-fiction at rt.cpan.org>, or through the web interface at
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.
=head1 ACKNOWLEDGEMENTS
=head1 COPYRIGHT & LICENSE
Copyright 2007 Shlomi Fish, all rights reserved.
This program is released under the following license: MIT X11.
=cut