File Coverage

blib/lib/Decision/ACL/Rule.pm
Criterion Covered Total %
statement 72 72 100.0
branch 27 46 58.7
condition 19 29 65.5
subroutine 11 11 100.0
pod 0 6 0.0
total 129 164 78.6


line stmt bran cond sub pod time code
1             package Decision::ACL::Rule;
2              
3              
4 2     2   14 use strict;
  2         5  
  2         60  
5 2     2   11 use Carp;
  2         3  
  2         117  
6 2     2   2282 use Data::Dumper;
  2         21623  
  2         158  
7              
8 2     2   15 use Decision::ACL::Constants qw(:rule);
  2         5  
  2         294  
9              
10 2     2   13 use constant DEBUG_LEVEL => 0;
  2         4  
  2         2258  
11            
12             sub new
13             {
14 4     4 0 222 my $parent = shift;
15 4         7 my $args = shift;
16              
17 4 50       14 croak "No arguments to new()" if not defined $args;
18 4 50       15 croak "Arguments to new() is not a hashref" if !UNIVERSAL::isa($args, 'HASH');
19 4 50       17 croak "No fields specified for new()" if not defined $args->{fields};
20 4 50       18 croak "Fields argument is not a hashref" if !UNIVERSAL::isa($args->{fields}, 'HASH');
21              
22 4         7 my $self = {};
23 4         10 bless $self, $parent;
24              
25 4         14 $self->Now($args->{now});
26 4         11 $self->Action($args->{action});
27 4         13 $self->Fields($args->{fields});
28              
29 4         11 return $self;
30             }
31              
32             sub Fields
33             {
34 64     64 0 91 my $self = shift;
35 64         87 my $fields = shift;
36              
37 64 100 66     253 if(defined $fields && (UNIVERSAL::isa($fields, 'HASH')))
38             {
39 4         14 foreach my $field (keys %$fields)
40             {
41 16         38 $self->{_fields}->{$field} = $fields->{$field};
42 16 50       52 $self->{_fields}->{$field} = uc $fields->{$field} if $fields->{$field} eq 'all';
43             }
44 4         11 $self->{_fields_loaded} = 1;
45             }
46              
47 64   50     273 return $self->{_fields} || {};
48             }
49              
50             sub Now
51             {
52 6     6 0 9 my $self = shift;
53 6         10 my $flag = shift;
54              
55 6 100       36 if(not defined $flag) { return $self->{_now}; }
  2         8  
56 4 100       14 if($flag == 1) { $self->{_now} = 1; }
  2 50       6  
57 2         9 elsif($flag == 0) { $self->{_now} = 0; }
58 4         10 return $self->{_now};
59             }
60              
61              
62             sub Action
63             {
64 26     26 0 38 my $self = shift;
65 26         38 my $action = shift;
66              
67 26 0 33     101 if(defined $action && ($action =~ /^ALLOW$/i
      66        
68             || $action =~ /^DENY$/i
69             || $action =~ /^PERMIT$/i
70             || $action =~ /^BLOCK$/i))
71             {
72 4         9 $self->{_action} = $action;
73 4         20 return $self->{_action};
74             }
75 22         89 return $self->{_action};
76             }
77              
78              
79             sub Control
80             {
81 14     14 0 22 my $self = shift;
82 14         21 my $args = shift;
83              
84 14 50       36 croak "Rule parameters not specified" if(!$self->{_fields_loaded});
85 14 50       27 croak "Rule action is not set" if(!$self->Action());
86 14 50       47 croak "Nothing to control" if(!$args);
87 14 50       46 croak "Arguments to control() is not a hashref" if !UNIVERSAL::isa($args, 'HASH');
88              
89             # Applying our action...
90             # - Check if we are concerned
91             # - If so, apply our action
92 14         31 my $concern_status = $self->Concerned($args);
93              
94 14 50       50 print STDERR "Concerned -> $concern_status\n" if $self->DEBUG_LEVEL();
95              
96             #It's ours, apply.
97 14 100       34 if($concern_status != ACL_RULE_UNCONCERNED)
98             {
99 4 50       14 print STDERR "We are concerned, action is '". $self->Action()."'\n" if $self->DEBUG_LEVEL();;
100 4 100 66     9 return ACL_RULE_ALLOW if($self->Action() =~ /^ALLOW$/i
101             || $self->Action() =~ /^PERMIT/i);
102 2 50 33     7 return ACL_RULE_DENY if($self->Action() =~ /^DENY$/i
103             || $self->ACtion() =~ /^BLOCK$/i);
104             }
105            
106 10         26 return ACL_RULE_UNCONCERNED;
107             }
108            
109             sub Concerned
110             {
111 14     14 0 19 my $self = shift;
112 14         19 my $args = shift;
113            
114 14 50       599 croak "No args to concern with" if (!$args);
115              
116             #Foreach field of this rule, check to see if we are concerned.
117 14         18 foreach my $field (keys %{$self->Fields()})
  14         29  
118             {
119 33         69 my $field_value = $self->Fields()->{$field};
120 33 50       110 print STDERR "$field control (".$field_value.")->" if $self->DEBUG_LEVEL();;
121            
122 33 50 100     239 return ACL_RULE_UNCONCERNED if(
      100        
      66        
      66        
123             $field_value ne $args->{$field}
124             && $field_value
125             && $field_value ne 'ALL'
126             && $args->{$field} ne 'ALL'
127             && $args->{$field});
128 23 50       80 print STDERR " 1\n" if $self->DEBUG_LEVEL();;
129             }
130              
131 4         10 return ACL_RULE_CONCERNED;
132             }
133              
134             666;