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 |