Filename | /Users/ap13/perl5/lib/perl5/File/Find/Rule.pm |
Statements | Executed 143 statements in 4.27ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 3.83ms | 4.03ms | BEGIN@9 | File::Find::Rule::
1 | 1 | 1 | 602µs | 827µs | BEGIN@6 | File::Find::Rule::
1 | 1 | 1 | 319µs | 400µs | BEGIN@7 | File::Find::Rule::
1 | 1 | 1 | 19µs | 19µs | import | File::Find::Rule::
1 | 1 | 1 | 15µs | 34µs | BEGIN@4 | File::Find::Rule::
1 | 1 | 1 | 10µs | 38µs | BEGIN@195 | File::Find::Rule::
1 | 1 | 1 | 9µs | 21µs | BEGIN@18 | File::Find::Rule::
1 | 1 | 1 | 8µs | 19µs | BEGIN@471 | File::Find::Rule::
1 | 1 | 1 | 8µs | 18µs | BEGIN@511 | File::Find::Rule::
1 | 1 | 1 | 8µs | 18µs | BEGIN@225 | File::Find::Rule::
1 | 1 | 1 | 7µs | 30µs | BEGIN@248 | File::Find::Rule::
1 | 1 | 1 | 7µs | 29µs | BEGIN@8 | File::Find::Rule::
1 | 1 | 1 | 7µs | 18µs | BEGIN@268 | File::Find::Rule::
1 | 1 | 1 | 6µs | 6µs | BEGIN@5 | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | AUTOLOAD | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | DESTROY | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | __ANON__[:267] | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | __ANON__[:435] | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | __ANON__[:470] | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | __ANON__[:509] | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | _call_find | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | _compile | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | _flatten | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | _force_object | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | any | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | discard | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | exec | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | find | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | grep | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | in | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | match | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | name | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | new | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | not | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | prune | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | relative | File::Find::Rule::
0 | 0 | 0 | 0s | 0s | start | File::Find::Rule::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # $Id$ | ||||
2 | |||||
3 | package File::Find::Rule; | ||||
4 | 2 | 26µs | 2 | 52µs | # spent 34µs (15+19) within File::Find::Rule::BEGIN@4 which was called:
# once (15µs+19µs) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 4 # spent 34µs making 1 call to File::Find::Rule::BEGIN@4
# spent 19µs making 1 call to strict::import |
5 | 2 | 24µs | 1 | 6µs | # spent 6µs within File::Find::Rule::BEGIN@5 which was called:
# once (6µs+0s) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 5 # spent 6µs making 1 call to File::Find::Rule::BEGIN@5 |
6 | 2 | 96µs | 2 | 865µs | # spent 827µs (602+225) within File::Find::Rule::BEGIN@6 which was called:
# once (602µs+225µs) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 6 # spent 827µs making 1 call to File::Find::Rule::BEGIN@6
# spent 38µs making 1 call to Exporter::import |
7 | 2 | 100µs | 1 | 400µs | # spent 400µs (319+82) within File::Find::Rule::BEGIN@7 which was called:
# once (319µs+82µs) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 7 # spent 400µs making 1 call to File::Find::Rule::BEGIN@7 |
8 | 2 | 22µs | 2 | 51µs | # spent 29µs (7+22) within File::Find::Rule::BEGIN@8 which was called:
# once (7µs+22µs) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 8 # spent 29µs making 1 call to File::Find::Rule::BEGIN@8
# spent 22µs making 1 call to Exporter::import |
9 | 2 | 151µs | 1 | 4.03ms | # spent 4.03ms (3.83+207µs) within File::Find::Rule::BEGIN@9 which was called:
# once (3.83ms+207µs) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 9 # spent 4.03ms making 1 call to File::Find::Rule::BEGIN@9 |
10 | |||||
11 | 1 | 800ns | our $VERSION = '0.33'; | ||
12 | |||||
13 | # we'd just inherit from Exporter, but I want the colon | ||||
14 | # spent 19µs within File::Find::Rule::import which was called:
# once (19µs+0s) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 14 of lib/Bio/Roary/CommandLine/RoaryPostAnalysis.pm | ||||
15 | 1 | 800ns | my $pkg = shift; | ||
16 | 1 | 900ns | my $to = caller; | ||
17 | 1 | 800ns | for my $sym ( qw( find rule ) ) { | ||
18 | 2 | 445µs | 2 | 34µs | # spent 21µs (9+12) within File::Find::Rule::BEGIN@18 which was called:
# once (9µs+12µs) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 18 # spent 21µs making 1 call to File::Find::Rule::BEGIN@18
# spent 12µs making 1 call to strict::unimport |
19 | 2 | 10µs | *{"$to\::$sym"} = \&{$sym}; | ||
20 | } | ||||
21 | 1 | 9µs | for (grep /^:/, @_) { | ||
22 | my ($extension) = /^:(.*)/; | ||||
23 | eval "require File::Find::Rule::$extension"; | ||||
24 | croak "couldn't bootstrap File::Find::Rule::$extension: $@" if $@; | ||||
25 | } | ||||
26 | } | ||||
27 | |||||
28 | =head1 NAME | ||||
29 | |||||
30 | File::Find::Rule - Alternative interface to File::Find | ||||
31 | |||||
32 | =head1 SYNOPSIS | ||||
33 | |||||
34 | use File::Find::Rule; | ||||
35 | # find all the subdirectories of a given directory | ||||
36 | my @subdirs = File::Find::Rule->directory->in( $directory ); | ||||
37 | |||||
38 | # find all the .pm files in @INC | ||||
39 | my @files = File::Find::Rule->file() | ||||
40 | ->name( '*.pm' ) | ||||
41 | ->in( @INC ); | ||||
42 | |||||
43 | # as above, but without method chaining | ||||
44 | my $rule = File::Find::Rule->new; | ||||
45 | $rule->file; | ||||
46 | $rule->name( '*.pm' ); | ||||
47 | my @files = $rule->in( @INC ); | ||||
48 | |||||
49 | =head1 DESCRIPTION | ||||
50 | |||||
51 | File::Find::Rule is a friendlier interface to File::Find. It allows | ||||
52 | you to build rules which specify the desired files and directories. | ||||
53 | |||||
54 | =cut | ||||
55 | |||||
56 | # the procedural shim | ||||
57 | |||||
58 | 1 | 1µs | *rule = \&find; | ||
59 | sub find { | ||||
60 | my $object = __PACKAGE__->new(); | ||||
61 | my $not = 0; | ||||
62 | |||||
63 | while (@_) { | ||||
64 | my $method = shift; | ||||
65 | my @args; | ||||
66 | |||||
67 | if ($method =~ s/^\!//) { | ||||
68 | # jinkies, we're really negating this | ||||
69 | unshift @_, $method; | ||||
70 | $not = 1; | ||||
71 | next; | ||||
72 | } | ||||
73 | unless (defined prototype $method) { | ||||
74 | my $args = shift; | ||||
75 | @args = ref $args eq 'ARRAY' ? @$args : $args; | ||||
76 | } | ||||
77 | if ($not) { | ||||
78 | $not = 0; | ||||
79 | @args = $object->new->$method(@args); | ||||
80 | $method = "not"; | ||||
81 | } | ||||
82 | |||||
83 | my @return = $object->$method(@args); | ||||
84 | return @return if $method eq 'in'; | ||||
85 | } | ||||
86 | $object; | ||||
87 | } | ||||
88 | |||||
89 | |||||
90 | =head1 METHODS | ||||
91 | |||||
92 | =over | ||||
93 | |||||
94 | =item C<new> | ||||
95 | |||||
96 | A constructor. You need not invoke C<new> manually unless you wish | ||||
97 | to, as each of the rule-making methods will auto-create a suitable | ||||
98 | object if called as class methods. | ||||
99 | |||||
100 | =cut | ||||
101 | |||||
102 | sub new { | ||||
103 | my $referent = shift; | ||||
104 | my $class = ref $referent || $referent; | ||||
105 | bless { | ||||
106 | rules => [], | ||||
107 | subs => {}, | ||||
108 | iterator => [], | ||||
109 | extras => {}, | ||||
110 | maxdepth => undef, | ||||
111 | mindepth => undef, | ||||
112 | }, $class; | ||||
113 | } | ||||
114 | |||||
115 | sub _force_object { | ||||
116 | my $object = shift; | ||||
117 | $object = $object->new() | ||||
118 | unless ref $object; | ||||
119 | $object; | ||||
120 | } | ||||
121 | |||||
122 | =back | ||||
123 | |||||
124 | =head2 Matching Rules | ||||
125 | |||||
126 | =over | ||||
127 | |||||
128 | =item C<name( @patterns )> | ||||
129 | |||||
130 | Specifies names that should match. May be globs or regular | ||||
131 | expressions. | ||||
132 | |||||
133 | $set->name( '*.mp3', '*.ogg' ); # mp3s or oggs | ||||
134 | $set->name( qr/\.(mp3|ogg)$/ ); # the same as a regex | ||||
135 | $set->name( 'foo.bar' ); # just things named foo.bar | ||||
136 | |||||
137 | =cut | ||||
138 | |||||
139 | sub _flatten { | ||||
140 | my @flat; | ||||
141 | while (@_) { | ||||
142 | my $item = shift; | ||||
143 | ref $item eq 'ARRAY' ? push @_, @{ $item } : push @flat, $item; | ||||
144 | } | ||||
145 | return @flat; | ||||
146 | } | ||||
147 | |||||
148 | sub name { | ||||
149 | my $self = _force_object shift; | ||||
150 | my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ } _flatten( @_ ); | ||||
151 | |||||
152 | push @{ $self->{rules} }, { | ||||
153 | rule => 'name', | ||||
154 | code => join( ' || ', map { "m{$_}" } @names ), | ||||
155 | args => \@_, | ||||
156 | }; | ||||
157 | |||||
158 | $self; | ||||
159 | } | ||||
160 | |||||
161 | =item -X tests | ||||
162 | |||||
163 | Synonyms are provided for each of the -X tests. See L<perlfunc/-X> for | ||||
164 | details. None of these methods take arguments. | ||||
165 | |||||
166 | Test | Method Test | Method | ||||
167 | ------|------------- ------|---------------- | ||||
168 | -r | readable -R | r_readable | ||||
169 | -w | writeable -W | r_writeable | ||||
170 | -w | writable -W | r_writable | ||||
171 | -x | executable -X | r_executable | ||||
172 | -o | owned -O | r_owned | ||||
173 | | | | ||||
174 | -e | exists -f | file | ||||
175 | -z | empty -d | directory | ||||
176 | -s | nonempty -l | symlink | ||||
177 | | -p | fifo | ||||
178 | -u | setuid -S | socket | ||||
179 | -g | setgid -b | block | ||||
180 | -k | sticky -c | character | ||||
181 | | -t | tty | ||||
182 | -M | modified | | ||||
183 | -A | accessed -T | ascii | ||||
184 | -C | changed -B | binary | ||||
185 | |||||
186 | Though some tests are fairly meaningless as binary flags (C<modified>, | ||||
187 | C<accessed>, C<changed>), they have been included for completeness. | ||||
188 | |||||
189 | # find nonempty files | ||||
190 | $rule->file, | ||||
191 | ->nonempty; | ||||
192 | |||||
193 | =cut | ||||
194 | |||||
195 | 2 | 101µs | 2 | 66µs | # spent 38µs (10+28) within File::Find::Rule::BEGIN@195 which was called:
# once (10µs+28µs) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 195 # spent 38µs making 1 call to File::Find::Rule::BEGIN@195
# spent 28µs making 1 call to vars::import |
196 | 1 | 19µs | %X_tests = ( | ||
197 | -r => readable => -R => r_readable => | ||||
198 | -w => writeable => -W => r_writeable => | ||||
199 | -w => writable => -W => r_writable => | ||||
200 | -x => executable => -X => r_executable => | ||||
201 | -o => owned => -O => r_owned => | ||||
202 | |||||
203 | -e => exists => -f => file => | ||||
204 | -z => empty => -d => directory => | ||||
205 | -s => nonempty => -l => symlink => | ||||
206 | => -p => fifo => | ||||
207 | -u => setuid => -S => socket => | ||||
208 | -g => setgid => -b => block => | ||||
209 | -k => sticky => -c => character => | ||||
210 | => -t => tty => | ||||
211 | -M => modified => | ||||
212 | -A => accessed => -T => ascii => | ||||
213 | -C => changed => -B => binary => | ||||
214 | ); | ||||
215 | |||||
216 | 1 | 5µs | for my $test (keys %X_tests) { | ||
217 | 27 | 1.77ms | my $sub = eval 'sub () { # spent 15µs executing statements in string eval
# spent 8µs executing statements in string eval
# spent 7µs executing statements in string eval
# spent 7µs executing statements in string eval
# spent 6µs executing statements in string eval
# spent 6µs executing statements in string eval
# spent 5µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 4µs executing statements in string eval
# spent 3µs executing statements in string eval
# spent 3µs executing statements in string eval
# spent 3µs executing statements in string eval
# spent 3µs executing statements in string eval
# spent 3µs executing statements in string eval
# spent 3µs executing statements in string eval
# spent 3µs executing statements in string eval | ||
218 | my $self = _force_object shift; | ||||
219 | push @{ $self->{rules} }, { | ||||
220 | code => "' . $test . ' \$_", | ||||
221 | rule => "'.$X_tests{$test}.'", | ||||
222 | }; | ||||
223 | $self; | ||||
224 | } '; | ||||
225 | 2 | 41µs | 2 | 28µs | # spent 18µs (8+10) within File::Find::Rule::BEGIN@225 which was called:
# once (8µs+10µs) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 225 # spent 18µs making 1 call to File::Find::Rule::BEGIN@225
# spent 10µs making 1 call to strict::unimport |
226 | 27 | 83µs | *{ $X_tests{$test} } = $sub; | ||
227 | } | ||||
228 | |||||
229 | |||||
230 | =item stat tests | ||||
231 | |||||
232 | The following C<stat> based methods are provided: C<dev>, C<ino>, | ||||
233 | C<mode>, C<nlink>, C<uid>, C<gid>, C<rdev>, C<size>, C<atime>, | ||||
234 | C<mtime>, C<ctime>, C<blksize>, and C<blocks>. See L<perlfunc/stat> | ||||
235 | for details. | ||||
236 | |||||
237 | Each of these can take a number of targets, which will follow | ||||
238 | L<Number::Compare> semantics. | ||||
239 | |||||
240 | $rule->size( 7 ); # exactly 7 | ||||
241 | $rule->size( ">7Ki" ); # larger than 7 * 1024 * 1024 bytes | ||||
242 | $rule->size( ">=7" ) | ||||
243 | ->size( "<=90" ); # between 7 and 90, inclusive | ||||
244 | $rule->size( 7, 9, 42 ); # 7, 9 or 42 | ||||
245 | |||||
246 | =cut | ||||
247 | |||||
248 | 2 | 134µs | 2 | 53µs | # spent 30µs (7+23) within File::Find::Rule::BEGIN@248 which was called:
# once (7µs+23µs) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 248 # spent 30µs making 1 call to File::Find::Rule::BEGIN@248
# spent 23µs making 1 call to vars::import |
249 | 1 | 4µs | @stat_tests = qw( dev ino mode nlink uid gid rdev | ||
250 | size atime mtime ctime blksize blocks ); | ||||
251 | { | ||||
252 | 2 | 900ns | my $i = 0; | ||
253 | 1 | 800ns | for my $test (@stat_tests) { | ||
254 | 13 | 3µs | my $index = $i++; # to close over | ||
255 | my $sub = sub { | ||||
256 | my $self = _force_object shift; | ||||
257 | |||||
258 | my @tests = map { Number::Compare->parse_to_perl($_) } @_; | ||||
259 | |||||
260 | push @{ $self->{rules} }, { | ||||
261 | rule => $test, | ||||
262 | args => \@_, | ||||
263 | code => 'do { my $val = (stat $_)['.$index.'] || 0;'. | ||||
264 | join ('||', map { "(\$val $_)" } @tests ).' }', | ||||
265 | }; | ||||
266 | $self; | ||||
267 | 13 | 37µs | }; | ||
268 | 2 | 497µs | 2 | 28µs | # spent 18µs (7+10) within File::Find::Rule::BEGIN@268 which was called:
# once (7µs+10µs) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 268 # spent 18µs making 1 call to File::Find::Rule::BEGIN@268
# spent 10µs making 1 call to strict::unimport |
269 | 13 | 22µs | *$test = $sub; | ||
270 | } | ||||
271 | } | ||||
272 | |||||
273 | =item C<any( @rules )> | ||||
274 | |||||
275 | =item C<or( @rules )> | ||||
276 | |||||
277 | Allows shortcircuiting boolean evaluation as an alternative to the | ||||
278 | default and-like nature of combined rules. C<any> and C<or> are | ||||
279 | interchangeable. | ||||
280 | |||||
281 | # find avis, movs, things over 200M and empty files | ||||
282 | $rule->any( File::Find::Rule->name( '*.avi', '*.mov' ), | ||||
283 | File::Find::Rule->size( '>200M' ), | ||||
284 | File::Find::Rule->file->empty, | ||||
285 | ); | ||||
286 | |||||
287 | =cut | ||||
288 | |||||
289 | sub any { | ||||
290 | my $self = _force_object shift; | ||||
291 | # compile all the subrules to code fragments | ||||
292 | push @{ $self->{rules} }, { | ||||
293 | rule => "any", | ||||
294 | code => '(' . join( ' || ', map '( ' . $_->_compile . ' )', @_ ). ')', | ||||
295 | args => \@_, | ||||
296 | }; | ||||
297 | |||||
298 | # merge all the subs hashes of the kids into ourself | ||||
299 | %{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_; | ||||
300 | $self; | ||||
301 | } | ||||
302 | |||||
303 | 1 | 900ns | *or = \&any; | ||
304 | |||||
305 | =item C<none( @rules )> | ||||
306 | |||||
307 | =item C<not( @rules )> | ||||
308 | |||||
309 | Negates a rule. (The inverse of C<any>.) C<none> and C<not> are | ||||
310 | interchangeable. | ||||
311 | |||||
312 | # files that aren't 8.3 safe | ||||
313 | $rule->file | ||||
314 | ->not( $rule->new->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) ); | ||||
315 | |||||
316 | =cut | ||||
317 | |||||
318 | sub not { | ||||
319 | my $self = _force_object shift; | ||||
320 | |||||
321 | push @{ $self->{rules} }, { | ||||
322 | rule => 'not', | ||||
323 | args => \@_, | ||||
324 | code => '(' . join ( ' && ', map { "!(". $_->_compile . ")" } @_ ) . ")", | ||||
325 | }; | ||||
326 | |||||
327 | # merge all the subs hashes into us | ||||
328 | %{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_; | ||||
329 | $self; | ||||
330 | } | ||||
331 | |||||
332 | 1 | 400ns | *none = \¬ | ||
333 | |||||
334 | =item C<prune> | ||||
335 | |||||
336 | Traverse no further. This rule always matches. | ||||
337 | |||||
338 | =cut | ||||
339 | |||||
340 | sub prune () { | ||||
341 | my $self = _force_object shift; | ||||
342 | |||||
343 | push @{ $self->{rules} }, | ||||
344 | { | ||||
345 | rule => 'prune', | ||||
346 | code => '$File::Find::prune = 1' | ||||
347 | }; | ||||
348 | $self; | ||||
349 | } | ||||
350 | |||||
351 | =item C<discard> | ||||
352 | |||||
353 | Don't keep this file. This rule always matches. | ||||
354 | |||||
355 | =cut | ||||
356 | |||||
357 | sub discard () { | ||||
358 | my $self = _force_object shift; | ||||
359 | |||||
360 | push @{ $self->{rules} }, { | ||||
361 | rule => 'discard', | ||||
362 | code => '$discarded = 1', | ||||
363 | }; | ||||
364 | $self; | ||||
365 | } | ||||
366 | |||||
367 | =item C<exec( \&subroutine( $shortname, $path, $fullname ) )> | ||||
368 | |||||
369 | Allows user-defined rules. Your subroutine will be invoked with C<$_> | ||||
370 | set to the current short name, and with parameters of the name, the | ||||
371 | path you're in, and the full relative filename. | ||||
372 | |||||
373 | Return a true value if your rule matched. | ||||
374 | |||||
375 | # get things with long names | ||||
376 | $rules->exec( sub { length > 20 } ); | ||||
377 | |||||
378 | =cut | ||||
379 | |||||
380 | sub exec { | ||||
381 | my $self = _force_object shift; | ||||
382 | my $code = shift; | ||||
383 | |||||
384 | push @{ $self->{rules} }, { | ||||
385 | rule => 'exec', | ||||
386 | code => $code, | ||||
387 | }; | ||||
388 | $self; | ||||
389 | } | ||||
390 | |||||
391 | =item C<grep( @specifiers )> | ||||
392 | |||||
393 | Opens a file and tests it each line at a time. | ||||
394 | |||||
395 | For each line it evaluates each of the specifiers, stopping at the | ||||
396 | first successful match. A specifier may be a regular expression or a | ||||
397 | subroutine. The subroutine will be invoked with the same parameters | ||||
398 | as an ->exec subroutine. | ||||
399 | |||||
400 | It is possible to provide a set of negative specifiers by enclosing | ||||
401 | them in anonymous arrays. Should a negative specifier match the | ||||
402 | iteration is aborted and the clause is failed. For example: | ||||
403 | |||||
404 | $rule->grep( qr/^#!.*\bperl/, [ sub { 1 } ] ); | ||||
405 | |||||
406 | Is a passing clause if the first line of a file looks like a perl | ||||
407 | shebang line. | ||||
408 | |||||
409 | =cut | ||||
410 | |||||
411 | sub grep { | ||||
412 | my $self = _force_object shift; | ||||
413 | my @pattern = map { | ||||
414 | ref $_ | ||||
415 | ? ref $_ eq 'ARRAY' | ||||
416 | ? map { [ ( ref $_ ? $_ : qr/$_/ ) => 0 ] } @$_ | ||||
417 | : [ $_ => 1 ] | ||||
418 | : [ qr/$_/ => 1 ] | ||||
419 | } @_; | ||||
420 | |||||
421 | $self->exec( sub { | ||||
422 | local *FILE; | ||||
423 | open FILE, $_ or return; | ||||
424 | local ($_, $.); | ||||
425 | while (<FILE>) { | ||||
426 | for my $p (@pattern) { | ||||
427 | my ($rule, $ret) = @$p; | ||||
428 | return $ret | ||||
429 | if ref $rule eq 'Regexp' | ||||
430 | ? /$rule/ | ||||
431 | : $rule->(@_); | ||||
432 | } | ||||
433 | } | ||||
434 | return; | ||||
435 | } ); | ||||
436 | } | ||||
437 | |||||
438 | =item C<maxdepth( $level )> | ||||
439 | |||||
440 | Descend at most C<$level> (a non-negative integer) levels of directories | ||||
441 | below the starting point. | ||||
442 | |||||
443 | May be invoked many times per rule, but only the most recent value is | ||||
444 | used. | ||||
445 | |||||
446 | =item C<mindepth( $level )> | ||||
447 | |||||
448 | Do not apply any tests at levels less than C<$level> (a non-negative | ||||
449 | integer). | ||||
450 | |||||
451 | =item C<extras( \%extras )> | ||||
452 | |||||
453 | Specifies extra values to pass through to C<File::File::find> as part | ||||
454 | of the options hash. | ||||
455 | |||||
456 | For example this allows you to specify following of symlinks like so: | ||||
457 | |||||
458 | my $rule = File::Find::Rule->extras({ follow => 1 }); | ||||
459 | |||||
460 | May be invoked many times per rule, but only the most recent value is | ||||
461 | used. | ||||
462 | |||||
463 | =cut | ||||
464 | |||||
465 | 1 | 700ns | for my $setter (qw( maxdepth mindepth extras )) { | ||
466 | my $sub = sub { | ||||
467 | my $self = _force_object shift; | ||||
468 | $self->{$setter} = shift; | ||||
469 | $self; | ||||
470 | 3 | 4µs | }; | ||
471 | 2 | 143µs | 2 | 30µs | # spent 19µs (8+11) within File::Find::Rule::BEGIN@471 which was called:
# once (8µs+11µs) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 471 # spent 19µs making 1 call to File::Find::Rule::BEGIN@471
# spent 11µs making 1 call to strict::unimport |
472 | 3 | 5µs | *$setter = $sub; | ||
473 | } | ||||
474 | |||||
475 | |||||
476 | =item C<relative> | ||||
477 | |||||
478 | Trim the leading portion of any path found | ||||
479 | |||||
480 | =cut | ||||
481 | |||||
482 | sub relative () { | ||||
483 | my $self = _force_object shift; | ||||
484 | $self->{relative} = 1; | ||||
485 | $self; | ||||
486 | } | ||||
487 | |||||
488 | =item C<not_*> | ||||
489 | |||||
490 | Negated version of the rule. An effective shortand related to ! in | ||||
491 | the procedural interface. | ||||
492 | |||||
493 | $foo->not_name('*.pl'); | ||||
494 | |||||
495 | $foo->not( $foo->new->name('*.pl' ) ); | ||||
496 | |||||
497 | =cut | ||||
498 | |||||
499 | sub DESTROY {} | ||||
500 | sub AUTOLOAD { | ||||
501 | our $AUTOLOAD; | ||||
502 | $AUTOLOAD =~ /::not_([^:]*)$/ | ||||
503 | or croak "Can't locate method $AUTOLOAD"; | ||||
504 | my $method = $1; | ||||
505 | |||||
506 | my $sub = sub { | ||||
507 | my $self = _force_object shift; | ||||
508 | $self->not( $self->new->$method(@_) ); | ||||
509 | }; | ||||
510 | { | ||||
511 | 2 | 451µs | 2 | 28µs | # spent 18µs (8+10) within File::Find::Rule::BEGIN@511 which was called:
# once (8µs+10µs) by Bio::Roary::CommandLine::RoaryPostAnalysis::BEGIN@14 at line 511 # spent 18µs making 1 call to File::Find::Rule::BEGIN@511
# spent 10µs making 1 call to strict::unimport |
512 | *$AUTOLOAD = $sub; | ||||
513 | } | ||||
514 | &$sub; | ||||
515 | } | ||||
516 | |||||
517 | =back | ||||
518 | |||||
519 | =head2 Query Methods | ||||
520 | |||||
521 | =over | ||||
522 | |||||
523 | =item C<in( @directories )> | ||||
524 | |||||
525 | Evaluates the rule, returns a list of paths to matching files and | ||||
526 | directories. | ||||
527 | |||||
528 | =cut | ||||
529 | |||||
530 | sub in { | ||||
531 | my $self = _force_object shift; | ||||
532 | |||||
533 | my @found; | ||||
534 | my $fragment = $self->_compile; | ||||
535 | my %subs = %{ $self->{subs} }; | ||||
536 | |||||
537 | warn "relative mode handed multiple paths - that's a bit silly\n" | ||||
538 | if $self->{relative} && @_ > 1; | ||||
539 | |||||
540 | my $topdir; | ||||
541 | my $code = 'sub { | ||||
542 | (my $path = $File::Find::name) =~ s#^(?:\./+)+##; | ||||
543 | my @args = ($_, $File::Find::dir, $path); | ||||
544 | my $maxdepth = $self->{maxdepth}; | ||||
545 | my $mindepth = $self->{mindepth}; | ||||
546 | my $relative = $self->{relative}; | ||||
547 | |||||
548 | # figure out the relative path and depth | ||||
549 | my $relpath = $File::Find::name; | ||||
550 | $relpath =~ s{^\Q$topdir\E/?}{}; | ||||
551 | my $depth = scalar File::Spec->splitdir($relpath); | ||||
552 | #print "name: \'$File::Find::name\' "; | ||||
553 | #print "relpath: \'$relpath\' depth: $depth relative: $relative\n"; | ||||
554 | |||||
555 | defined $maxdepth && $depth >= $maxdepth | ||||
556 | and $File::Find::prune = 1; | ||||
557 | |||||
558 | defined $mindepth && $depth < $mindepth | ||||
559 | and return; | ||||
560 | |||||
561 | #print "Testing \'$_\'\n"; | ||||
562 | |||||
563 | my $discarded; | ||||
564 | return unless ' . $fragment . '; | ||||
565 | return if $discarded; | ||||
566 | if ($relative) { | ||||
567 | push @found, $relpath if $relpath ne ""; | ||||
568 | } | ||||
569 | else { | ||||
570 | push @found, $path; | ||||
571 | } | ||||
572 | }'; | ||||
573 | |||||
574 | #use Data::Dumper; | ||||
575 | #print Dumper \%subs; | ||||
576 | #warn "Compiled sub: '$code'\n"; | ||||
577 | |||||
578 | my $sub = eval "$code" or die "compile error '$code' $@"; | ||||
579 | for my $path (@_) { | ||||
580 | # $topdir is used for relative and maxdepth | ||||
581 | $topdir = $path; | ||||
582 | # slice off the trailing slash if there is one (the | ||||
583 | # maxdepth/mindepth code is fussy) | ||||
584 | $topdir =~ s{/?$}{} | ||||
585 | unless $topdir eq '/'; | ||||
586 | $self->_call_find( { %{ $self->{extras} }, wanted => $sub }, $path ); | ||||
587 | } | ||||
588 | |||||
589 | return @found; | ||||
590 | } | ||||
591 | |||||
592 | sub _call_find { | ||||
593 | my $self = shift; | ||||
594 | File::Find::find( @_ ); | ||||
595 | } | ||||
596 | |||||
597 | sub _compile { | ||||
598 | my $self = shift; | ||||
599 | |||||
600 | return '1' unless @{ $self->{rules} }; | ||||
601 | my $code = join " && ", map { | ||||
602 | if (ref $_->{code}) { | ||||
603 | my $key = "$_->{code}"; | ||||
604 | $self->{subs}{$key} = $_->{code}; | ||||
605 | "\$subs{'$key'}->(\@args) # $_->{rule}\n"; | ||||
606 | } | ||||
607 | else { | ||||
608 | "( $_->{code} ) # $_->{rule}\n"; | ||||
609 | } | ||||
610 | } @{ $self->{rules} }; | ||||
611 | |||||
612 | #warn $code; | ||||
613 | return $code; | ||||
614 | } | ||||
615 | |||||
616 | =item C<start( @directories )> | ||||
617 | |||||
618 | Starts a find across the specified directories. Matching items may | ||||
619 | then be queried using L</match>. This allows you to use a rule as an | ||||
620 | iterator. | ||||
621 | |||||
622 | my $rule = File::Find::Rule->file->name("*.jpeg")->start( "/web" ); | ||||
623 | while ( defined ( my $image = $rule->match ) ) { | ||||
624 | ... | ||||
625 | } | ||||
626 | |||||
627 | =cut | ||||
628 | |||||
629 | sub start { | ||||
630 | my $self = _force_object shift; | ||||
631 | |||||
632 | $self->{iterator} = [ $self->in( @_ ) ]; | ||||
633 | $self; | ||||
634 | } | ||||
635 | |||||
636 | =item C<match> | ||||
637 | |||||
638 | Returns the next file which matches, false if there are no more. | ||||
639 | |||||
640 | =cut | ||||
641 | |||||
642 | sub match { | ||||
643 | my $self = _force_object shift; | ||||
644 | |||||
645 | return shift @{ $self->{iterator} }; | ||||
646 | } | ||||
647 | |||||
648 | 1 | 55µs | 1; | ||
649 | |||||
650 | __END__ |