File Coverage

blib/lib/Algorithm/IncludeExclude.pm
Criterion Covered Total %
statement 64 64 100.0
branch 16 16 100.0
condition 4 4 100.0
subroutine 8 8 100.0
pod 4 4 100.0
total 96 96 100.0


line stmt bran cond sub pod time code
1             package Algorithm::IncludeExclude;
2              
3 10     10   9985323 use warnings;
  10         28  
  10         336  
4 10     10   53 use strict;
  10         21  
  10         327  
5 10     10   54 use Carp;
  10         21  
  10         8724  
6              
7             =head1 NAME
8              
9             Algorithm::IncludeExclude - build and evaluate include/exclude lists
10              
11             =head1 VERSION
12              
13             Version 0.01
14              
15             =cut
16              
17             our $VERSION = '0.01';
18              
19             =head1 SYNOPSIS
20              
21             Algorithm::IncludeExclude lets you define a tree of include / exclude
22             rules and then allows you to determine the best rule for a given path.
23              
24             For example, to include everything, then exclude everything under
25             C or C but then include everything under C, you
26             could write:
27              
28             my $ie = Algorithm::IncludeExclude->new;
29            
30             # setup rules
31             $ie->include(); # default to include
32             $ie->exclude('foo');
33             $ie->exclude('bar');
34             $ie->include(qw/foo baz/);
35              
36             # evaluate candidates
37             $ie->evaluate(qw/foo bar/); # exclude (due to 'foo' rule)
38             $ie->evaluate(qw/bar baz/); # exclude (due to 'bar' rule)
39             $ie->evaluate(qw/quux foo bar/); # include (due to '' rule)
40             $ie->evaluate(qw/foo baz quux/); # include (due to 'foo/baz' rule)
41              
42             You can also match against regexes. Let's imagine you want to exclude
43             everything in the C directory, as well as all files that end
44             with a C<.protected> extension.
45              
46             Here's how to implement that:
47              
48             my $ie = Algorithm::IncludeExclude->new;
49             $ie->exclude('admin');
50             $ie->exclude(qr/[.]protected$/);
51              
52             $ie->evaluate(qw/admin let me in/); # exclude (due to 'admin' rule)
53             $ie->evaluate(qw/a path.protected/); # exclude (due to regex)
54             $ie->evaluate(qw/foo bar/); # undefined (no rule matches)
55              
56             $ie->include(qw/foo bar/);
57             $ie->evaluate(qw/foo bar/); # now it's included
58              
59             If you wanted to include files inside the C path ending in C<.ok>,
60             you could just add this rule:
61              
62             $ie->include('admin', qr/[.]ok$/);
63             $ie->evaluate(qw/admin super public records.ok/); # included
64              
65             The most specific match always wins -- if there's not an exact match,
66             the nearest match is chosen instead.
67              
68             =head1 NOTES
69              
70             =over 4
71              
72             =item *
73              
74             Regexes can only appear as the last element in a rule:
75              
76             $ie->include(qr/foo/, qr/bar/);
77             $ie->exclude(qr/foo/, qr/bar/);
78              
79             If regexes were allowed anywhere, things could get very confusing,
80             very quickly.
81              
82             =item *
83              
84             Regexes are matched against any remaining path elements when they are
85             first encountered. In the following example:
86              
87             $ie->include('foo', qr/bar/);
88             $ie->evaluate('foo', 'baz', 'quux', 'bar'); # include
89              
90             The match works like this. First, 'foo' (from the include rule) and
91             'foo' (from the path being evaluated) are compared. Since there's a
92             match, the next element in the path is examined against C's
93             subtree. The only remaining item in the rule tree is a regex, so the
94             regex is compared to the rest of the path being evaluated, joined by
95             the C argument to new (see L); namely:
96              
97             baz/quux/bar
98              
99             Since the regular expression matches this string, the include rule is
100             matched.
101              
102             =item *
103              
104             Regex rules are checked before non-regex rules. For example:
105              
106             $ie->exclude('foo', 'bar');
107             $ie->include(qr/bar/);
108              
109             $ie->evaluate('foo', 'bar'); # include, due to regex
110              
111             =item *
112              
113             If two or more regular expressions at the same level match a path, the
114             result is undefined:
115              
116             $ie->include(qr/foo/);
117             $ie->exclude(qr/bar/);
118            
119             $ie->evaluate('foobar'); # undef is returned
120              
121             =back
122              
123             =cut
124              
125             =head1 METHODS
126              
127             =head2 new
128              
129             Create a new instance. Accepts an optional hashref of arguments. The
130             arguments may be:
131              
132             =over 4
133              
134             =item join
135              
136             String to join remaining path elements with when matching against a
137             regex. Defaults to C, which is good for matching against URLs or
138             filesystem paths.
139              
140             =back
141              
142             =cut
143              
144             # self is a tree, that looks like:
145             # {path1 => [ value1, {path2 => [ value2, ... ]}]}
146             # path1 has value value1
147             # path1->path2 has value value2
148             # path3 is undefined
149             # etc
150              
151             sub new {
152 9     9 1 113 my $class = shift;
153 9   100     73 my $args = shift || {};
154 9   100     68 $args->{join} ||= ''; # avoid warnings
155 9         19 $args->{regexes} = {};
156 9         30 my $self = [undef, {}, $args];
157 9         37 return bless $self => $class;
158             }
159              
160             # walks down the tree and sets the value of path to value
161             sub _set {
162 39     39   56 my $tree = shift;
163 39         44 my $path = shift;
164 39         46 my $value = shift;
165            
166 39         91 my $regexes = $tree->[2]->{regexes};
167              
168 39         46 my $ref = 0;
169 39         72 foreach my $head (@$path){
170             # ignore everything after a qr// rule
171 56 100       193 croak "Ignoring values after a qr// rule" if $ref;
172 48 100       104 if(ref $head){
173 20         25 $ref = 1;
174 20         60 $regexes->{"X$head"} = $head;
175 20         56 $head = "X$head";
176             }
177             else {
178 28         64 $head = "0$head";
179             }
180 48         95 my $node = $tree->[1]->{$head};
181 48 100       169 $node = $tree->[1]->{$head} = [undef, {}]
182             if('ARRAY' ne ref $node);
183            
184 48         103 $tree = $node;
185             }
186 31         104 $tree->[0] = $value;
187             }
188              
189             =head2 include(@path)
190              
191             Add an include path to the rule tree. C<@path> may end with a regex.
192              
193             =cut
194              
195             sub include {
196 19     19 1 4021 my $self = shift;
197 19         57 my @path = @_;
198 19         53 $self->_set(\@path, 1);
199             }
200              
201             =head2 exclude(@path)
202              
203             Add an exclude path to the rule tree. C<@path> may end with a regex.
204              
205             =cut
206              
207             sub exclude {
208 20     20 1 3100 my $self = shift;
209 20         46 my @path = @_;
210 20         58 $self->_set(\@path, 0);
211             }
212              
213             =head2 evaluate(@path)
214              
215             Evaluate whether C<@path> should be included (true) or excluded
216             (false). If the include/exclude status cannot be determined (no rules
217             match, more than one regex matches), C is returned.
218              
219             =cut
220              
221             sub evaluate {
222 51     51 1 108 my $self = shift;
223 51         115 my @path = @_;
224 51         94 my $value = $self->[0];
225 51         87 my $tree = [@{$self}]; # unbless
  51         6791562  
226              
227             # "constants" (in here anyway)
228 51         73 my %REGEXES = %{$self->[2]->{regexes}};
  51         178  
229 51         103 my $JOIN = $self->[2]->{join};
230            
231 51         153 while(my $head = shift @path){
232             # get regexes at this level;
233 29         63 my @regexes =
234 29         83 grep { defined }
235 90         341 map { $REGEXES{$_} }
236 64         155 grep { /^X/ }
237 64         82 keys %{$tree->[1]};
238            
239 64 100       161 if(@regexes){
240 22         33 my $matches = 0;
241 22         52 my $rest = join $JOIN, ($head,@path);
242 22         36 foreach my $regex (@regexes){
243 29 100       148 if($rest =~ /$regex/){
244 17         43 $value = $tree->[1]->{"X$regex"}->[0];
245 17         46 $matches++;
246             }
247             }
248 22 100       123 return undef if($matches > 1);
249 18 100       89 return $value if $matches == 1;
250             }
251              
252 51         109 $tree = $tree->[1]->{"0$head"};
253 51 100       167 last unless ref $tree;
254 27         88 $value = $tree->[0];
255             }
256              
257 38         204 return $value;
258             }
259              
260             =head1 AUTHOR
261              
262             Jonathan Rockway, C<< >>
263              
264             =head1 BUGS
265              
266             Please report any bugs or feature requests to
267             C, or through the web interface at
268             L.
269             I will be notified, and then you'll automatically be notified of progress on
270             your bug as I make changes.
271              
272             =head1 SUPPORT
273              
274             You can find documentation for this module with the perldoc command.
275              
276             perldoc Algorithm::IncludeExclude
277              
278             You can also look for information at:
279              
280             =over 4
281              
282             =item * AnnoCPAN: Annotated CPAN documentation
283              
284             L
285              
286             =item * CPAN Ratings
287              
288             L
289              
290             =item * RT: CPAN's request tracker
291              
292             L
293              
294             =item * Search CPAN
295              
296             L
297              
298             =back
299              
300             =head1 ACKNOWLEDGEMENTS
301              
302             =head1 COPYRIGHT & LICENSE
303              
304             Copyright 2007 Jonathan Rockway, all rights reserved.
305              
306             This program is free software; you can redistribute it and/or modify it
307             under the same terms as Perl itself.
308              
309             =cut
310              
311             1; # End of Algorithm::IncludeExclude