/usr/share/doc/libparse-recdescent-perl/examples/demo_simple.pl is in libparse-recdescent-perl 1.967009+dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | use v5.10;
use warnings;
# WHO IS NEXT TO WHOM?
use Parse::RecDescent;
$grammar =
q{
<nocheck>
inputs : input(s)
input : who_question "\n" {1}
| is_question "\n" {1}
| statement "\n" {1}
| /bye|quit|exit/ { exit }
| <reject:!$text> <error> # ERROR IF NOT END OF TEXT
| { print STDERR "resyncing\n" }
{ _error(@$_) foreach @{$thisparser->{errors}}; }
<resync>
statement: namelist are <commit> 'next' 'to' namelist
{ ::nextto $item[1], $item[6], $thisline; 1 }
| <error?> <reject>
who_question:
'who' <commit> are 'next' 'to' name '?'
{ ::whonextto $item[6] ; 1 }
| <error?> <reject>
is_question:
'is' <commit> name 'next' 'to' name '?'
{ ::isnextto($item[3], $item[6]); 1 }
| <error?> <reject>
namelist : name(s) 'and' <commit> namelist
{ [ @{$item[1]}, @{$item[3]} ] }
| name(s)
name : ...!'who' ...!'and' ...!are /[A-Za-z]+/
are : 'is' | 'are'
};
$parse = new Parse::RecDescent ($grammar);
$parse->{tokensep} = '[ \t]*';
$input = '';
print "> ";
while (<>)
{
if (/^\.$/) { $parse->inputs($input) || print "huh?\n"; $input = '' }
else { $input .= $_ }
print "> ";
}
sub nextto($$$)
{
foreach $A ( @{$_[0]} ) {
foreach $B ( @{$_[1]} ) {
nexttoAB($A,$B,$_[2]);
}
}
print "okay\n";
}
sub nexttoAB($$$)
{
$nextto{$_[0]} or $nextto{$_[0]} = [];
$nextto{$_[1]} or $nextto{$_[1]} = [];
push @{$nextto{$_[0]}}, $_[1];
push @{$nextto{$_[1]}}, $_[0];
print "Learnt something from line $_[2]\n";
}
sub whonextto($)
{
if (defined $nextto{$_[0]})
{ print join(" and ", @{$nextto{$_[0]}}) . ".\n"; }
else
{ print "sorry, I've never heard of $_[0].\n"; }
}
sub isnextto($$)
{
if (!$nextto{$_[0]})
{ print "sorry, I've never heard of $_[0].\n"; }
elsif (!$nextto{$_[1]})
{ print "sorry, I've never heard of $_[1].\n"; }
else
{
foreach $name (@{$nextto{$_[0]}})
{
if ($name eq $_[1]) { print "yes\n"; return }
}
print "no\n";
}
}
|