File Coverage

lib/Net/Sieve/Script/Rule.pm
Criterion Covered Total %
statement 172 204 84.3
branch 70 110 63.6
condition 18 26 69.2
subroutine 16 17 94.1
pod 11 11 100.0
total 287 368 77.9


line stmt bran cond sub pod time code
1             package Net::Sieve::Script::Rule;
2 8     8   85114 use strict;
  8         19  
  8         291  
3 8     8   41 use warnings;
  8         15  
  8         247  
4 8     8   80 use base qw(Class::Accessor::Fast);
  8         14  
  8         3114  
5              
6 8     8   10964 use vars qw($VERSION);
  8         19  
  8         603  
7              
8             $VERSION = '0.08';
9              
10 8     8   4209 use Net::Sieve::Script::Action;
  8         20  
  8         69  
11 8     8   3907 use Net::Sieve::Script::Condition;
  8         22  
  8         60  
12              
13             =head1 NAME
14              
15             Net::Sieve::Script::Rule - parse and write rules in sieve scripts
16              
17             =head1 SYNOPSIS
18              
19             use Net::Sieve::Script::Rule;
20             my $pRule = Net::Sieve::Script::Rule->new (
21             ctrl => $ctrl,
22             test_list => $test_list,
23             block => $block,
24             order => $order
25             );
26              
27             or
28             my $rule = Net::Sieve::Script::Rule->new();
29             my $cond = Net::Sieve::Script::Condition->new('header');
30             $cond->match_type(':contains');
31             $cond->header_list('"Subject"');
32             $cond->key_list('"Re: Test2"');
33             my $actions = 'fileinto "INBOX.test"; stop;';
34              
35             $rule->add_condition($cond);
36             $rule->add_action($actions);
37              
38             print $rule->write;
39              
40             =head1 DESCRIPTION
41              
42              
43              
44             =cut
45              
46             __PACKAGE__->mk_accessors(qw(alternate conditions actions priority require));
47              
48             =head1 CONSTRUCTOR
49              
50             =head2 new
51              
52             Arguments :
53             order => : optionnal set priority for rule
54             ctrl => : optionnal default 'if', else could be 'else', 'elsif'
55             or 'vacation'
56             test_list => : optionnal conditions by string or by Condition Object
57             block => : optionnal block of commands
58             Returns : Net::Sieve::Script::Rule object
59              
60             Set accessors
61              
62             alternate : as param ctrl
63             conditions : first condition in tree
64             actions : array of actions objects
65             priority : rule order in script, main id for rule
66             require :
67              
68              
69             =cut
70              
71             sub new
72             {
73 34     34 1 4559 my ($class, %param) = @_;
74              
75 34   33     208 my $self = bless ({}, ref ($class) || $class);
76              
77 34   100     1185 $self->alternate(lc($param{ctrl})||'if');
78 34 100       337 $self->priority($param{order}) if $param{order};
79              
80 34 100       188 if ($param{block}) {
81 30         35 my @Actions;
82 30         109 my @commands = split( ';' , $param{block});
83 30         50 foreach my $command (@commands) {
84 58         201 push @Actions, Net::Sieve::Script::Action->new($command);
85             };
86 30         95 $self->actions(\@Actions);
87             }
88              
89 34 100       225 if ($param{test_list}) {
90 26 50       166 my $cond = ( ref($param{test_list}) eq 'Net::Sieve::Script::Condition' ) ?
91             $param{test_list} :
92             Net::Sieve::Script::Condition->new($param{test_list});
93 26         78 $self->conditions($cond);
94             }
95              
96              
97 34         210 return $self;
98             }
99              
100             =head1 METHODS
101              
102             =head2 equals
103              
104             return 1 if rules are equals
105              
106             =cut
107              
108             sub equals {
109 0     0 1 0 my $self = shift;
110 0         0 my $object = shift;
111              
112 0 0       0 return 0 unless (defined $object);
113 0 0       0 return 0 unless ($object->isa('Net::Sieve::Script::Rule'));
114              
115             # Should we test "id" ? Probably not it's internal to the
116             # representaion of this object, and not a part of what actually makes
117             # it a sieve "condition"
118              
119             #my @accessors = qw( alternate require );
120 0         0 my @accessors = qw( alternate );
121              
122 0         0 foreach my $accessor ( @accessors ) {
123 0         0 my $myvalue = $self->$accessor;
124 0         0 my $theirvalue = $object->$accessor;
125 0 0       0 if (defined $myvalue) {
126 0 0       0 return 0 unless (defined $theirvalue);
127 0 0       0 return 0 unless ($myvalue eq $theirvalue);
128             } else {
129 0 0       0 return 0 if (defined $theirvalue);
130             }
131             }
132              
133 0 0       0 if ( defined $self->conditions ) {
134 0 0       0 return 0 unless ($self->conditions->isa(
135             'Net::Sieve::Script::Condition'));
136 0 0       0 return 0 unless ($self->conditions->equals($object->conditions));
137             } else {
138 0 0       0 return 0 if (defined $object->conditions ) ;
139             }
140              
141 0 0       0 if (defined $self->actions) {
142 0         0 my $tmp = $self->actions;
143 0         0 my @myactions = @$tmp;
144 0         0 $tmp = $object->actions;
145 0         0 my @theiractions = @$tmp;
146 0 0       0 return 0 unless ($#myactions == $#theiractions);
147              
148 0 0       0 unless ($#myactions == -1) {
149 0         0 foreach my $index (0..$#myactions) {
150 0         0 my $myaction = $myactions[$index];
151 0         0 my $theiraction = $theiractions[$index];
152 0 0       0 if (defined ($myaction)) {
153 0 0       0 return 0 unless ($myaction->isa(
154             'Net::Sieve::Script::Action'));
155 0 0       0 return 0 unless ($myaction->equals($theiraction));
156             } else {
157 0 0       0 return 0 if (defined ($theiraction));
158             }
159             }
160             }
161              
162             } else {
163 0 0       0 return 0 if (defined ($object->actions));
164             }
165              
166 0         0 return 1;
167             }
168              
169             =head2 write
170              
171             Return rule in text format
172              
173             =cut
174              
175             sub write
176             {
177 17     17 1 29 my $self = shift;
178              
179             # for simple vacation RFC 5230
180 17 100       41 if ( $self->alternate eq 'vacation' ) {
181 2         16 return $self->write_action;
182             }
183              
184 15 100       98 my $write_condition = ($self->write_condition)?$self->write_condition:'';
185 15 50       54 my $write_action = ($self->write_action)?$self->write_action:'';
186              
187 15         44 return $self->alternate.' '.
188             $write_condition."\n".
189             ' {'.
190             "\n".$write_action.
191             ' } ';
192             }
193              
194             =head2 write_condition
195              
196             set require for used conditions
197             return conditions in text format
198              
199             =cut
200              
201             sub write_condition
202             {
203 30     30 1 48 my $self = shift;
204              
205 30 100       68 return undef if ! $self->conditions;
206              
207 28 100       162 if ( defined $self->conditions->require ) {
208 2         14 my $require = $self->require();
209 2         8 push @{$require}, @{$self->conditions->require};
  2         4  
  2         6  
210 2         16 $self->require($require);
211             };
212              
213 28         206 return $self->conditions->write();
214             }
215              
216             =head2 write_action
217              
218             set require for used actions
219             return actions in text format
220              
221             =cut
222              
223             sub write_action
224             {
225 35     35 1 45 my $self = shift;
226              
227 35         84 my $actions = '';
228 35         89 my $require = $self->require();
229              
230 35         123 foreach my $command ( @{$self->actions()} ) {
  35         118  
231 73 100       462 next if (! $command->command);
232 49         263 $actions .= ' '.$command->command;
233 49 100       240 $actions .= ' '.$command->param if ($command->param);
234 49         307 $actions .= ";\n";
235 49 100 100     146 push (@{$require}, $command->command) if (
  29   100     499  
236             $command->command ne 'keep' &&
237             $command->command ne 'discard' &&
238             # $command->command ne 'reject' &&
239             $command->command ne 'stop' ); # rfc 3528 4.) implementation MUST support
240             }
241 35         288 $self->require($require);
242 35         205 return $actions;
243             }
244              
245             =head2 delete_condition
246              
247             Purpose : delete condition by rule, delete all block on delete anyof/allof
248             delete single anyof/allof block : single condition move up
249             Arguments : condition id
250             Returns : 1 on success, 0 on error
251              
252             =cut
253              
254             sub delete_condition
255             {
256 5     5 1 303 my $self = shift;
257 5         6 my $id = shift;
258              
259 5         15 my $cond_to_delete = $self->conditions->AllConds->{$id};
260 5 100       42 return 0 if (! defined $cond_to_delete);
261              
262 4         11 delete $self->conditions->AllConds->{$id};
263              
264 4 100       34 if (! defined $cond_to_delete->parent) {
265 1         7 $self->conditions(undef);
266 1         6 return 1;
267             }
268 3         16 my @parent_conditions = @{$cond_to_delete->parent->condition()};
  3         8  
269 3         21 my @new_conditions = ();
270 3         7 foreach my $cond (@parent_conditions) {
271 8 100       36 push @new_conditions, $cond if ( $cond->id != $id );
272             }
273              
274             # remove single block
275 3 100       22 if ( scalar @new_conditions == 1 ) {
276 2         13 my $last_cond = $new_conditions[0];
277 2         7 my $parent = $last_cond->parent;
278 2         11 my $old_parent = $parent->parent;
279 2         42 my $new_cond = Net::Sieve::Script::Condition->new($last_cond->write);
280 2         8 $self->delete_condition($parent->id);
281 2 100       10 $self->add_condition($new_cond,(defined $old_parent)?$old_parent->id:0);
282             }
283              
284 3         10 $cond_to_delete->parent->condition(\@new_conditions);
285 3         40 return 1;
286             }
287              
288             =head2 add_condition
289              
290             Purpose : add condition to rule, add 'allof' group on second rule
291             Arguments : string or Condition object
292             Returns : new condition id or 0 on error
293              
294             =cut
295              
296             sub add_condition
297             {
298 11     11 1 938 my $self = shift;
299 11         13 my $cond = shift;
300 11         15 my $parent_id = shift;
301 11 100       42 $cond = ref($cond) eq 'Net::Sieve::Script::Condition' ? $cond : Net::Sieve::Script::Condition->new($cond);
302              
303 11 100       27 if ($parent_id) {
304             # add new condition to anyof/allof parent block
305 4         9 my $parent = $self->conditions->AllConds->{$parent_id};
306 4 100 33     34 return 0 if (!$parent || ( $parent->test ne 'allof' && $parent->test ne 'anyof') );
      66        
307 3 100       18 my @conditions_list = (defined $parent->condition())?@{$parent->condition()}:();
  2         11  
308 3         18 $cond->parent($parent);
309 3         12 push @conditions_list, $cond;
310 3         7 $parent->condition(\@conditions_list);
311 3         25 return 1;
312             }
313              
314 7 100       23 if ( defined $self->conditions() ) {
315 4 100 66     22 if ( $self->conditions->test eq 'anyof'
316             || $self->conditions->test eq 'allof' ) {
317             # add condition on first block
318 2         24 my @conditions_list = @{$self->conditions->condition()};
  2         5  
319 2         13 $cond->parent($self->conditions);
320 2         11 push @conditions_list, $cond;
321 2         4 $self->conditions->condition(\@conditions_list);
322             }
323             else {
324             # add a new block on second add
325 2         41 my $new_anyoff = Net::Sieve::Script::Condition->new('allof');
326 2         4 my @conditions_list = ();
327 2         6 $cond->parent($new_anyoff);
328 2         14 $self->conditions->parent($new_anyoff);
329 2         18 push @conditions_list, $self->conditions;
330 2         9 push @conditions_list, $cond;
331 2         22 $new_anyoff->condition(\@conditions_list);
332 2         14 $self->conditions($new_anyoff);
333             }
334             }
335             else {
336             # add first condition
337 3         24 $self->conditions($cond);
338             }
339              
340 7         58 return $cond->id;
341             }
342              
343             =head2 swap_actions
344              
345             swap actions by order
346             return 1 on succes, 0 on failure
347              
348             =cut
349              
350             sub swap_actions
351             {
352 4     4 1 7 my $self = shift;
353 4         6 my $swap1 = shift;
354 4         35 my $swap2 = shift;
355              
356 4 100       13 return 0 if $swap1 == $swap2;
357 3 50       7 return 0 if (! defined $self->actions);
358 3 100 66     28 return 0 if $swap1 <= 0 || $swap2 <= 0;
359              
360 2         3 my $pa1 = $self->find_action($swap1);
361 2         10 my $pa2 = $self->find_action($swap2);
362              
363 2 100       9 return 0 if ref($pa1) ne 'Net::Sieve::Script::Action';
364 1 50       3 return 0 if ref($pa2) ne 'Net::Sieve::Script::Action';
365              
366 1         1 my @Actions = @{$self->actions()};
  1         3  
367 1         5 my @NewActions = ();
368              
369 1         2 my $i = 1 ;
370 1         2 foreach my $action (@{$self->actions()}) {
  1         3  
371 3 100       10 if ($i == $swap1 ) {
    100          
372 1         2 push @NewActions, $pa2;
373             }
374             elsif ($i == $swap2 ) {
375 1         2 push @NewActions, $pa1;
376             }
377             else {
378 1         1 push @NewActions, $action;
379             };
380 3         5 $i++;
381             }
382 1         3 $self->actions(\@NewActions);
383              
384 1         7 return 1;
385             }
386              
387             =head2 find_action
388              
389             find action by order
390             Returns: Net::Sieve::Script::Action object, 0 on error
391              
392             =cut
393              
394             sub find_action
395             {
396 8     8 1 11 my $self = shift;
397 8         9 my $order = shift;
398              
399 8 100       17 return 0 if (! defined $self->actions);
400 7         31 my @Actions = @{$self->actions()};
  7         12  
401 7         28 my $i = 1;
402 7         11 foreach my $action (@Actions) {
403 15 100       34 return $action if ($i == $order);
404 10         13 $i++;
405             }
406              
407 2         6 return 0;
408             }
409              
410             =head2 delete_action
411              
412             delete action by order, first is 1;
413              
414             =cut
415              
416             sub delete_action
417             {
418 4     4 1 8 my $self = shift;
419 4         6 my $order = shift;
420 4         4 my $deleted = 0;
421 4         5 my @NewActions;
422              
423 4 100       10 return 0 if (! defined $self->actions);
424 2         10 my @Actions = @{$self->actions()};
  2         5  
425              
426 2         8 my $i = 1;
427 2         3 foreach my $action (@Actions) {
428 3 100       8 if ($i == $order) {
429 1         1 $deleted = 1;
430             }
431             else {
432 2         3 push @NewActions, $action;
433             };
434 3         4 $i++;
435             };
436              
437 2         5 $self->actions(\@NewActions);
438              
439 2         24 return $deleted;
440             }
441              
442             =head2 add_action
443              
444             Purpose : add action at end of block
445             Arguments : command line
446             or command line list with ; separator
447             or Net::Sieve::Script::Action object
448             Return : 1 on success
449              
450             =cut
451              
452             sub add_action
453             {
454 7     7 1 26 my $self = shift;
455 7         9 my $action = shift;
456              
457 7 100       19 my @Actions = defined $self->actions?@{$self->actions()}:();
  4         23  
458              
459 7 100 66     70 if ($action =~m /;/g && ref($action) ne 'Net::Sieve::Script::Action' ) {
460 2         8 my @list_actions = split(';',$action);
461 2         12 foreach my $sub_action (@list_actions) {
462 4         16 push @Actions, Net::Sieve::Script::Action->new($sub_action);
463             }
464             } else {
465              
466 5 100       26 my $pAction = (ref($action) eq 'Net::Sieve::Script::Action')?$action:Net::Sieve::Script::Action->new($action);
467              
468 5         8 push @Actions, $pAction;
469             }
470              
471 7         21 $self->actions(\@Actions);
472              
473 7         37 return 1;
474             }
475              
476              
477             =head1 AUTHOR
478              
479             Yves Agostini
480             CPAN ID: YVESAGO
481             Univ Metz
482             agostini@univ-metz.fr
483             http://www.crium.univ-metz.fr
484              
485             =head1 COPYRIGHT
486              
487             This program is free software; you can redistribute
488             it and/or modify it under the same terms as Perl itself.
489              
490             The full text of the license can be found in the
491             LICENSE file included with this module.
492              
493             =cut
494              
495             return 1;
496