File Coverage

lib/Badger/Logic.pm
Criterion Covered Total %
statement 88 93 94.6
branch 25 40 62.5
condition 15 30 50.0
subroutine 26 26 100.0
pod 9 10 90.0
total 163 199 81.9


line stmt bran cond sub pod time code
1             #========================================================================
2             #
3             # Badger::Logic
4             #
5             # DESCRIPTION
6             # Simple parser and evaluator for boolean logic expressions, e.g.
7             # 'purple or orange', 'animal and (eats_nuts or eats_berries)'
8             #
9             # AUTHOR
10             # Andy Wardley
11             #
12             #========================================================================
13              
14             package Badger::Logic;
15              
16             use Badger::Class
17 2         18 version => 0.01,
18             debug => 0,
19             base => 'Badger::Base',
20             as_text => 'text',
21             constants => 'HASH',
22             constant => {
23             LOGIC => 'Badger::Logic',
24             },
25             exports => {
26             any => 'LOGIC Logic',
27             },
28             messages => {
29             no_text => 'No text expression specified.',
30             no_rhs => 'Missing expression following "%s"',
31             bad_text => 'Unexpected text in expression: %s',
32             parse => 'Could not parse logic expression: %s',
33             no_rparen => 'Missing ")" at end of nested expression',
34 2     2   444 };
  2         5  
35              
36             our $NODE = {
37             'item' => 'Badger::Logic::Item',
38             'not' => 'Badger::Logic::Not',
39             'and' => 'Badger::Logic::And',
40             'or' => 'Badger::Logic::Or',
41             };
42              
43             *test = \&evaluate;
44              
45              
46             sub Logic {
47             return @_
48 3 100   3 1 27 ? LOGIC->new(@_)
49             : LOGIC;
50             }
51              
52             sub new {
53 26     26 1 212 my $class = shift;
54 26         31 my $text = shift;
55 26 50       50 return $class->error_msg('no_text')
56             unless defined $text;
57 26 50       111 bless {
58             text => ref $text ? $text : \$text,
59             }, $class;
60             }
61              
62             sub evaluate {
63 21     21 1 27 my $self = shift;
64 21 50 33     83 my $args = @_ && ref $_[0] eq HASH ? shift : { @_ };
65 21         35 $self->tree->evaluate($args);
66             }
67              
68             sub tree {
69 22     22 1 23 my $self = shift;
70             return $self->{ tree }
71 22   33     58 ||= $self->parse($self->{ text });
72             }
73              
74             sub text {
75 8     8 1 14 ${ shift->{ text } };
  8         19  
76             }
77              
78             sub tree_text {
79 1     1 0 3 shift->tree->text;
80             }
81              
82             sub parse {
83 22     22 1 22 my $self = shift;
84 22         23 my $text = shift;
85 22 50       36 my $tref = ref $text ? $text : \$text;
86 22         21 $self->debug("parse($$tref)\n") if DEBUG;
87 22   50     35 my $expr = $self->parse_expr($tref)
88             || return $self->error_msg( parse => $$tref );
89 22         25 $self->debug("expr: ", $expr->text) if DEBUG;
90 22 50       43 if ($$tref =~ / \G \s* (.+) $/cigsx) {
91 0         0 return $self->error_msg( bad_text => $1 );
92             }
93 22         65 return $expr;
94             }
95              
96             sub parse_expr {
97 73     73 1 76 my $self = shift;
98 73         70 my $text = shift;
99 73   50     103 my $left = $self->parse_unary($text) || return;
100              
101 73         81 $self->debug("got unary: ", $left->text) if DEBUG;
102              
103 73 100       194 if ($$text =~ / \G \s+ (and|or) \s+ /cigx) {
    50          
104 35         89 my $op = $1;
105 35 50       53 $self->debug("binary op: $op\n") if $DEBUG;
106 35   50     67 my $right = $self->parse_expr($text)
107             || return $self->error_msg( no_rhs => $op );
108 35         91 return $NODE->{ lc $op }->new( $left, $right );
109             }
110             elsif ($$text =~ / \G \s* \( /cgx) {
111 0   0     0 my $expr = $self->parse_expr($text)
112             || return $self->error_msg( no_rhs => '(' );
113 0 0       0 $$text =~ / \G \s* \) /cgx
114             || return $self->error_msg('no_rparen');
115              
116 0         0 return $self->error_msg( bad_text => $1 );
117             }
118              
119 38         72 return $left;
120             }
121              
122             sub parse_unary {
123 73     73 1 74 my $self = shift;
124 73         69 my $text = shift;
125              
126 73 100       176 if ($$text =~ / \G \s* (not) \s+ /cigx) {
127 13         27 my $op = $1;
128 13 50       24 $self->debug("unary op: $op\n") if $DEBUG;
129 13   50     23 my $right = $self->parse_term($text)
130             || return $self->error_msg( no_rhs => $op );
131 13         39 return $NODE->{ lc $op }->new($right);
132             }
133 60   33     100 return $self->parse_term($text)
134             || $self->decline('Not a unary expression');
135             }
136              
137             sub parse_term {
138 73     73 1 81 my $self = shift;
139 73         75 my $text = shift;
140              
141 73 100       218 if ($$text =~ / \G \s* (\w+) /cigx) {
    100          
    50          
142 54 50       81 $self->debug("item: $1\n") if $DEBUG;
143 54         105 return $NODE->{ item }->new($1);
144             }
145             elsif ($$text =~ / \G \s* (['"]) ((?:\\?.)*?) \1 /cigx) {
146 3 50       6 $self->debug("string: $2\n") if $DEBUG;
147 3         6 return $NODE->{ item }->new($2);
148             }
149             elsif ($$text =~ / \G \s* \( /cgx) {
150 16   50     30 my $expr = $self->parse_expr($text)
151             || return $self->error_msg( no_rhs => '(' );
152 16 50       53 $$text =~ / \G \s* \) /cgx
153             || return $self->error_msg('no_rparen');
154 16         38 return $expr;
155             }
156              
157 0         0 return $self->decline('Not a term');
158             }
159              
160              
161             #=======================================================================
162             # node types
163             #=======================================================================
164              
165             package Badger::Logic::Expr;
166 2     2   13 use base 'Badger::Base';
  2         4  
  2         335  
167              
168             sub new {
169 105     105   122 my $class = shift;
170 105         342 bless [ @_ ], $class;
171             }
172              
173             package Badger::Logic::Item;
174 2     2   13 use base 'Badger::Logic::Expr';
  2         6  
  2         1132  
175              
176             sub evaluate {
177 41     41   44 my $self = shift;
178 41 50 33     114 my $args = @_ && ref $_[0] eq 'HASH' ? shift : { @_ };
179 41         165 return $args->{ $self->[0] };
180             }
181              
182             sub text {
183 4     4   20 $_[0]->[0];
184             }
185              
186             package Badger::Logic::Not;
187 2     2   14 use base 'Badger::Logic::Expr';
  2         2  
  2         655  
188              
189             sub evaluate {
190 12     12   14 my $self = shift;
191 12 100       21 return $self->[0]->evaluate(@_) ? 0 : 1;
192             }
193              
194             sub text {
195 1     1   2 my $self = shift;
196 1         3 '(not ' . $self->[0]->text . ')';
197             }
198              
199             package Badger::Logic::And;
200 2     2   13 use base 'Badger::Logic::Expr';
  2         2  
  2         653  
201              
202             sub evaluate {
203 15     15   19 my $self = shift;
204 15   100     25 return $self->[0]->evaluate(@_)
205             && $self->[1]->evaluate(@_);
206             }
207              
208             sub text {
209 2     2   4 my $self = shift;
210 2         5 '(' . $self->[0]->text . ' and ' . $self->[1]->text . ')';
211             }
212              
213             package Badger::Logic::Or;
214 2     2   12 use base 'Badger::Logic::Expr';
  2         2  
  2         466  
215              
216 2     2   12 use Badger::Debug ':all';
  2         4  
  2         15  
217             sub evaluate {
218 16     16   22 my $self = shift;
219 16   100     26 return $self->[0]->evaluate(@_)
220             || $self->[1]->evaluate(@_);
221             }
222              
223             sub text {
224 1     1   2 my $self = shift;
225 1         3 '(' . $self->[0]->text . ' or ' . $self->[1]->text . ')';
226             }
227              
228             1;
229             __END__