/usr/share/doc/libparse-recdescent-perl/examples/demo_OOautoparsetree.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 | #!/usr/bin/perl -sw
# PARSE AND EVALUATE LOGICAL EXPRESSIONS WITH A AUTOGENERATED OO PARSE TREE
use Parse::RecDescent;
use Data::Dumper;
sub trace_only {
my ($pattern) = @_;
$RD_TRACE=1;
my $_real_trace = \&Parse::RecDescent::_trace;
*Parse::RecDescent::_trace = sub ($;$$$) {
my ($msg, $context, $rulename, $level) = @_;
return if $msg !~ $pattern;
goto &{$_real_trace};
};
}
my $parse = Parse::RecDescent->new(<<'EOG');
<autotree: LOGICAL>
expr : set | clear | disj
set : 'set' atom
clear : 'clear' atom
disj : <leftop: conj 'or' conj>
{ bless $item[-1], 'LOGICAL::'.$item[0] }
conj : <leftop: unary 'and' unary>
{ bless $item[-1], 'LOGICAL::'.$item[0] }
unary : neg | bracket | atom
bracket : '(' expr ')'
neg : 'not' unary
atom : /[a-z]+/i
EOG
trace_only( qr/Matched|consumed/ );
while (<DATA>)
{
my $tree = $parse->expr($_);
print Data::Dumper->Dump([$tree]);
print $tree->eval(), "\n" if $tree;
}
BEGIN {@var{qw(a c e)} = (1,1,1);}
sub returning
{
# local $^W;
# print +(caller(1))[3], " returning ($_[0])\n";
$_[0];
}
sub LOGICAL::expr::eval { my $type = $_[0]->{set}||$_[0]->{clear}
||$_[0]->{disj};
returning $type->eval() }
sub LOGICAL::disj::eval { returning join '', map {$_->eval()} @{$_[0]} }
sub LOGICAL::conj::eval { returning ! join '', map {! $_->eval()} @{$_[0]} }
sub LOGICAL::unary::eval { my $type = $_[0]->{neg}||$_[0]->{bracket}
||$_[0]->{atom};
returning $type->eval() }
sub LOGICAL::bracket::eval { returning $_[0]->{expr}->eval() }
sub LOGICAL::neg::eval { returning ! $_[0]->{unary}->eval() }
sub LOGICAL::set::eval { returning $::var{$_[0]->{atom}->name()} = 1 }
sub LOGICAL::clear::eval { returning $::var{$_[0]->{atom}->name()} = 0 }
sub LOGICAL::atom::eval { returning $::var{$_[0]->{__VALUE__}} }
sub LOGICAL::atom::name { returning $_[0]->{__VALUE__} }
__DATA__
a or b and not c or d
|