File Coverage

blib/lib/Circle/Rule/Store.pm
Criterion Covered Total %
statement 42 207 20.2
branch 0 50 0.0
condition 0 5 0.0
subroutine 14 42 33.3
pod 0 30 0.0
total 56 334 16.7


line stmt bran cond sub pod time code
1             # You may distribute under the terms of the GNU General Public License
2             #
3             # (C) Paul Evans, 2008-2010 -- leonerd@leonerd.org.uk
4              
5             package Circle::Rule::Store;
6              
7 4     4   18 use strict;
  4         6  
  4         115  
8 4     4   16 use warnings;
  4         5  
  4         100  
9              
10 4     4   17 use Carp;
  4         6  
  4         225  
11              
12 4     4   1538 use Circle::Rule::Chain;
  4         7  
  4         113  
13 4     4   24 use Circle::Rule::Resultset;
  4         5  
  4         89  
14              
15 4     4   2680 use Text::Balanced qw( extract_bracketed );
  4         37977  
  4         380  
16              
17 4     4   35 use Attribute::Storage qw( get_subattrs );
  4         6  
  4         34  
18              
19             #############################################
20             ### Attribute handlers for command_* subs ###
21             #############################################
22              
23             sub Rule_description :ATTR(CODE)
24             {
25 61     61 0 6889 my $class = shift;
26 61         80 my ( $text ) = @_;
27              
28 61         132 return $text;
29 4     4   377 }
  4         8  
  4         27  
30              
31             sub Rule_format :ATTR(CODE)
32             {
33 61     61 0 4329 my $class = shift;
34 61         74 my ( $format ) = @_;
35              
36 61         122 return $format;
37 4     4   965 }
  4         6  
  4         16  
38              
39             sub new
40             {
41 0     0 0   my $class = shift;
42 0           my %args = @_;
43              
44             my $self = bless {
45             cond => {},
46             action => {},
47              
48             parent => $args{parent},
49              
50 0           chains => {},
51             }, $class;
52              
53 0           $self->register_cond( not => $self );
54 0           $self->register_cond( any => $self );
55 0           $self->register_cond( all => $self );
56              
57 0           return $self;
58             }
59              
60             sub register_cond
61             {
62 0     0 0   my $self = shift;
63 0           my ( $name, $obj ) = @_;
64              
65 0 0         croak "Already have a condition function called $name" if exists $self->{cond}->{$name};
66              
67 0           foreach my $method ( "parse_cond_$name", "deparse_cond_$name", "eval_cond_$name" ) {
68 0 0         eval { $obj->can( $method ) } or
  0            
69             croak "Expected that $obj can $method";
70             }
71              
72 0           $self->{cond}->{$name} = { obj => $obj };
73             }
74              
75             sub list_conds
76             {
77 0     0 0   my $self = shift;
78 0           return ( keys %{ $self->{cond} } ),
79 0 0         ( $self->{parent} ? $self->{parent}->list_conds : () );
80             }
81              
82             sub get_cond
83             {
84 0     0 0   my $self = shift;
85 0           my ( $name ) = @_;
86              
87 0 0         return $self->{cond}->{$name} if $self->{cond}->{$name};
88 0 0         return $self->{parent}->get_cond( $name ) if $self->{parent};
89              
90 0           die "No such condition '$name'\n";
91             }
92              
93             sub parse_cond
94             {
95 0     0 0   my $self = shift;
96             # my ( $spec ) = @_ but we'll use $_[0] for alias
97              
98 0 0         $_[0] =~ s/^(\w+)\s*// or die "Expected a condition name\n";
99 0           my $condname = $1;
100              
101 0           my $cond = $self->get_cond( $condname );
102              
103 0           my $condspec;
104 0 0         if( $_[0] =~ m/^\(/ ) {
105 0           $condspec = extract_bracketed( $_[0], q{("')} );
106 0 0         defined $condspec or die "Bad argument spec '$condspec' for condition $condname\n";
107 0           s/^\(\s*//, s/\s*\)$// for $condspec;
108             }
109              
110 0           my $method = "parse_cond_$condname";
111              
112 0           my @condargs = eval { $cond->{obj}->$method( $condspec ) };
  0            
113 0 0         if( $@ ) {
114 0           my $err = $@; chomp $err;
  0            
115 0           die "$err while parsing condition spec '$condspec' for $condname\n";
116             }
117              
118 0           return [ $condname, @condargs ];
119             }
120              
121             sub deparse_cond
122             {
123 0     0 0   my $self = shift;
124 0           my ( $condref ) = @_;
125              
126 0           my ( $name, @args ) = @$condref;
127              
128 0           my $cond = $self->get_cond( $name );
129              
130 0           my $method = "deparse_cond_$name";
131 0           my $argspec = $cond->{obj}->$method( @args );
132              
133 0 0         return defined $argspec ? "$name($argspec)" : $name;
134             }
135              
136             sub eval_cond
137             {
138 0     0 0   my $self = shift;
139 0           my ( $condref, $event, $results ) = @_;
140              
141 0           my ( $name, @args ) = @$condref;
142              
143 0           my $cond = $self->get_cond( $name );
144              
145 0           my $method = "eval_cond_$name";
146 0           return $cond->{obj}->$method( $event, $results, @args );
147             }
148              
149             sub describe_cond
150             {
151 0     0 0   my $self = shift;
152 0           my ( $name ) = @_;
153              
154 0           my $cond = $self->get_cond( $name );
155              
156 0           my $attrs = get_subattrs( $cond->{obj}->can( "parse_cond_$name" ) );
157            
158             return {
159             desc => $attrs->{Rule_description},
160             format => $attrs->{Rule_format},
161 0           };
162             }
163              
164             sub register_action
165             {
166 0     0 0   my $self = shift;
167 0           my ( $name, $obj ) = @_;
168              
169 0 0         croak "Already have a action function called $name" if exists $self->{action}->{$name};
170              
171 0           foreach my $method ( "parse_action_$name", "deparse_action_$name", "eval_action_$name" ) {
172 0 0         eval { $obj->can( $method ) } or
  0            
173             croak "Expected that $obj can $method";
174             }
175              
176 0           $self->{action}->{$name} = { obj => $obj };
177             }
178              
179             sub list_actions
180             {
181 0     0 0   my $self = shift;
182 0           return ( keys %{ $self->{action} } ),
183 0 0         ( $self->{parent} ? $self->{parent}->list_actions : () );
184             }
185              
186             sub get_action
187             {
188 0     0 0   my $self = shift;
189 0           my ( $name ) = @_;
190              
191 0 0         return $self->{action}->{$name} if $self->{action}->{$name};
192 0 0         return $self->{parent}->get_action( $name ) if $self->{parent};
193              
194 0           die "No such action '$name'\n";
195             }
196              
197             sub parse_action
198             {
199 0     0 0   my $self = shift;
200             # my ( $spec ) = @_ but we'll use $_[0] for alias
201              
202 0 0         $_[0] =~ s/^(\w+)\s*// or die "Expected an action name, found '$_[0]'\n";
203 0           my $actionname = $1;
204              
205 0           my $action = $self->get_action( $actionname );
206              
207 0           my $actionspec;
208 0 0         if( $_[0] =~ m/^\(/ ) {
209 0           $actionspec = extract_bracketed( $_[0], q{("')} );
210 0 0         defined $actionspec or die "Bad argument spec '$actionspec' for action $actionname\n";
211 0           s/^\(\s*//, s/\s*\)$// for $actionspec;
212             }
213              
214 0           my $method = "parse_action_$actionname";
215              
216 0           my @actionargs = eval { $action->{obj}->$method( $actionspec ) };
  0            
217 0 0         if( $@ ) {
218 0           my $err = $@; chomp $err;
  0            
219 0           die "$err while parsing condition spec '$actionspec' for $actionname\n";
220             }
221              
222 0           return [ $actionname, @actionargs ];
223             }
224              
225             sub deparse_action
226             {
227 0     0 0   my $self = shift;
228 0           my ( $actionref ) = @_;
229              
230 0           my ( $name, @args ) = @$actionref;
231              
232 0           my $action = $self->get_action( $name );
233              
234 0           my $method = "deparse_action_$name";
235 0           my $argspec = $action->{obj}->$method( @args );
236              
237 0 0         return defined $argspec ? "$name($argspec)" : $name;
238             }
239              
240             sub eval_action
241             {
242 0     0 0   my $self = shift;
243 0           my ( $actionref, $event, $results ) = @_;
244              
245 0           my ( $name, @args ) = @$actionref;
246              
247 0           my $action = $self->get_action( $name );
248              
249 0           my $method = "eval_action_$name";
250 0           return $action->{obj}->$method( $event, $results, @args );
251             }
252              
253             sub describe_action
254             {
255 0     0 0   my $self = shift;
256 0           my ( $name ) = @_;
257              
258 0           my $action = $self->get_action( $name );
259              
260 0           my $attrs = get_subattrs( $action->{obj}->can( "parse_action_$name" ) );
261            
262             return {
263             desc => $attrs->{Rule_description},
264             format => $attrs->{Rule_format},
265 0           };
266             }
267              
268             sub new_chain
269             {
270 0     0 0   my $self = shift;
271 0           my ( $name ) = @_;
272              
273 0   0       $self->{chains}->{$name} ||= Circle::Rule::Chain->new( $self );
274             }
275              
276             sub chains
277             {
278 0     0 0   my $self = shift;
279 0           return keys %{ $self->{chains} };
  0            
280             }
281              
282             sub get_chain
283             {
284 0     0 0   my $self = shift;
285 0           my ( $chainname ) = @_;
286              
287 0   0       return $self->{chains}->{$chainname} || die "No such rulechain called $chainname\n";
288             }
289              
290             sub run
291             {
292 0     0 0   my $self = shift;
293 0           my ( $chainname, $event ) = @_;
294              
295 0 0         my $chain = $self->{chains}->{$chainname} or die "No such rulechain called $chainname\n";
296              
297 0           $chain->run( $event );
298             }
299              
300             # Internal rules for boolean logic
301              
302             sub parse_cond_not
303             : Rule_description("Invert the sense of a sub-condition")
304             : Rule_format('condition')
305             {
306 0     0 0 0 my $self = shift;
307 0         0 my ( $spec ) = @_;
308              
309 0         0 return $self->parse_cond( $spec );
310 4     4   8109 }
  4         7  
  4         18  
311              
312             sub deparse_cond_not
313             {
314 0     0 0   my $self = shift;
315 0           my ( $cond ) = @_;
316              
317 0           return $self->deparse_cond( $cond );
318             }
319              
320             sub eval_cond_not
321             {
322 0     0 0   my $self = shift;
323 0           my ( $event, $results, $cond ) = @_;
324              
325             # Construct a new result set which we throw away
326 0           return not $self->eval_cond( $cond, $event, Circle::Rule::Resultset->new() );
327             }
328              
329             sub parse_cond_any
330             : Rule_description("Check if any sub-condition is true")
331             : Rule_format('condition ...')
332             {
333 0     0 0 0 my $self = shift;
334 0         0 my ( $spec ) = @_;
335              
336 0         0 my @conds;
337 0         0 while( length $spec ) {
338 0         0 push @conds, $self->parse_cond( $spec );
339              
340 0         0 $spec =~ s/\s+//; # trim ws
341             }
342              
343 0 0       0 @conds or die "Expected at least one condition\n";
344              
345 0         0 return @conds;
346 4     4   1106 }
  4         11  
  4         15  
347              
348             sub deparse_cond_any
349             {
350 0     0 0   my $self = shift;
351 0           my ( @conds ) = @_;
352              
353 0           return join( " ", map { $self->deparse_cond( $_ ) } @conds );
  0            
354             }
355              
356             sub eval_cond_any
357             {
358 0     0 0   my $self = shift;
359 0           my ( $event, $results, @conds ) = @_;
360              
361 0           foreach my $cond ( @conds ) {
362 0 0         return 1 if $self->eval_cond( $cond, $event, $results );
363             }
364              
365 0           return 0;
366             }
367              
368             sub parse_cond_all
369             : Rule_description("Check if all sub-conditions are true")
370             : Rule_format('condition ...')
371             {
372 0     0 0   my $self = shift;
373 0           my ( $spec ) = @_;
374              
375 0           my @conds;
376 0           while( length $spec ) {
377 0           push @conds, $self->parse_cond( $spec );
378              
379 0           $spec =~ s/\s+//; # trim ws
380             }
381              
382 0 0         @conds or die "Expected at least one condition\n";
383              
384 0           return @conds;
385 4     4   1164 }
  4         6  
  4         15  
386              
387             sub deparse_cond_all
388             {
389 0     0 0   my $self = shift;
390 0           my ( @conds ) = @_;
391              
392 0           return join( " ", map { $self->deparse_cond( $_ ) } @conds );
  0            
393             }
394              
395             sub eval_cond_all
396             {
397 0     0 0   my $self = shift;
398 0           my ( $event, $results, @conds ) = @_;
399              
400             # Construct sub-results because we don't want any results to apply if a
401             # later failure causes us to fail after an earlier cond was successful and
402             # stored results
403 0           my $subresults = Circle::Rule::Resultset->new();
404              
405 0           foreach my $cond ( @conds ) {
406 0 0         return 0 unless $self->eval_cond( $cond, $event, $subresults );
407             }
408              
409 0           $results->merge_from( $subresults );
410 0           return 1;
411             }
412              
413             0x55AA;