File Coverage

blib/lib/File/Find/Object/Rule.pm
Criterion Covered Total %
statement 216 292 73.9
branch 41 50 82.0
condition 7 9 77.7
subroutine 43 45 95.5
pod 15 15 100.0
total 322 411 78.3


line stmt bran cond sub pod time code
1             # $Id: /mirror/lab/perl/File-Find-Rule/lib/File/Find/Rule.pm 2102 2006-06-01T15:39:03.942922Z richardc $
2              
3             package File::Find::Object::Rule;
4             $File::Find::Object::Rule::VERSION = '0.0312';
5 1     1   60036 use strict;
  1         10  
  1         23  
6 1     1   4 use warnings;
  1         2  
  1         19  
7              
8 1     1   19 use 5.008;
  1         2  
9              
10 1     1   4 use vars qw/$AUTOLOAD/;
  1         1  
  1         54  
11 1     1   6 use File::Spec;
  1         1  
  1         34  
12 1     1   401 use Text::Glob 'glob_to_regex';
  1         679  
  1         48  
13 1     1   362 use Number::Compare;
  1         354  
  1         26  
14 1     1   5 use Carp qw/croak/;
  1         1  
  1         36  
15 1     1   430 use File::Find::Object; # we're only wrapping for now
  1         10305  
  1         22  
16 1     1   6 use File::Basename;
  1         2  
  1         82  
17 1     1   6 use Cwd; # 5.00503s File::Find goes screwy with max_depth == 0
  1         1  
  1         60  
18              
19 1         8 use Class::XSAccessor accessors => {
20             "extras" => "extras",
21             "finder" => "finder",
22             "_match_cb" => "_match_cb",
23             "rules" => "rules",
24             "_relative" => "_relative",
25             "_subs" => "_subs",
26             "_maxdepth" => "_maxdepth",
27             "_mindepth" => "_mindepth",
28 1     1   5 };
  1         1  
29              
30             # we'd just inherit from Exporter, but I want the colon
31             sub import
32             {
33 4     4   607 my $pkg = shift;
34 4         10 my $to = caller;
35 4         6 for my $sym (qw( find rule ))
36             {
37 1     1   398 no strict 'refs';
  1         2  
  1         554  
38 8         10 *{"$to\::$sym"} = \&{$sym};
  8         42  
  8         14  
39             }
40 4         42 for ( grep /^:/, @_ )
41             {
42 2         8 my ($extension) = /^:(.*)/;
43 2         116 eval "require File::Find::Object::Rule::$extension";
44 2 100       609 croak "couldn't bootstrap File::Find::Object::Rule::$extension: $@"
45             if $@;
46             }
47             }
48              
49              
50             # the procedural shim
51              
52             *rule = \&find;
53              
54             sub find
55             {
56 28     28 1 690 my $object = __PACKAGE__->new();
57 28         54 my $not = 0;
58              
59 28         53 while (@_)
60             {
61 74         96 my $method = shift;
62 74         90 my @args;
63              
64 74 100       149 if ( $method =~ s/^\!// )
65             {
66             # jinkies, we're really negating this
67 1         4 unshift @_, $method;
68 1         2 $not = 1;
69 1         3 next;
70             }
71 73 100       168 unless ( defined prototype $method )
72             {
73 53         68 my $args = shift;
74 53 100       126 @args = ref $args eq 'ARRAY' ? @$args : $args;
75             }
76 73 100       130 if ($not)
77             {
78 1         2 $not = 0;
79 1         4 @args = ref($object)->new->$method(@args);
80 1         2 $method = "not";
81             }
82              
83 73         385 my @return = $object->$method(@args);
84 73 100       254 return @return if $method eq 'in';
85             }
86 13         31 $object;
87             }
88              
89              
90             sub new
91             {
92             # We need this to maintain compatibility with File-Find-Object.
93             # However, Randal Schwartz recommends against this practice in general:
94             # http://www.stonehenge.com/merlyn/UnixReview/col52.html
95 54     54 1 1624 my $referent = shift;
96 54   66     158 my $class = ref $referent || $referent;
97              
98 54         255 return bless {
99             rules => [], # [0]
100             _subs => [], # [1]
101             iterator => [],
102             extras => {},
103             _maxdepth => undef,
104             _mindepth => undef,
105             _relative => 0,
106             }, $class;
107             }
108              
109             sub _force_object
110             {
111 310     310   415 my $object = shift;
112 310 100       573 if ( !ref($object) )
113             {
114 22         43 $object = $object->new();
115             }
116 310         715 return $object;
117             }
118              
119              
120             sub _flatten
121             {
122 20     20   27 my @flat;
123 20         43 while (@_)
124             {
125 23         29 my $item = shift;
126 23 100       71 ref $item eq 'ARRAY' ? push @_, @{$item} : push @flat, $item;
  1         4  
127             }
128 20         40 return @flat;
129             }
130              
131             sub _add_rule
132             {
133 78     78   99 my $self = shift;
134 78         90 my $new_rule = shift;
135              
136 78         89 push @{ $self->rules() }, $new_rule;
  78         147  
137              
138 78         339 return;
139             }
140              
141             sub name
142             {
143 20     20 1 1022 my $self = _force_object shift;
144 20 100       42 my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ } _flatten(@_);
  22         285  
145              
146             $self->_add_rule(
147             {
148             rule => 'name',
149 20         457 code => join( ' || ', map { "m($_)" } @names ),
  22         126  
150             args => \@_,
151             }
152             );
153              
154 20         77 $self;
155             }
156              
157              
158 1     1   7 use vars qw( %X_tests );
  1         1  
  1         153  
159             %X_tests = (
160             -r => readable => -R => r_readable => -w => writeable => -W =>
161             r_writeable => -w => writable => -W => r_writable => -x =>
162             executable => -X => r_executable => -o => owned => -O => r_owned =>
163              
164             -e => exists => -f => file => -z => empty => -d => directory => -s =>
165             nonempty => -l => symlink => => -p => fifo => -u => setuid => -S =>
166             socket => -g => setgid => -b => block => -k => sticky => -c =>
167             character => => -t => tty => -M => modified => -A => accessed => -T =>
168             ascii => -C => changed => -B => binary =>
169             );
170              
171             for my $test ( keys %X_tests )
172             {
173             my $sub = eval 'sub () {
174             my $self = _force_object shift;
175             $self->_add_rule({
176             code => "' . $test . ' \$path",
177 0     0   0 rule => "' . $X_tests{$test} . '",
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  3         12  
  3         16  
  3         13  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  13         40  
  13         55  
  13         51  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
178             });
179             $self;
180             } ';
181 1     1   6 no strict 'refs';
  1         2  
  1         36  
182             *{ $X_tests{$test} } = $sub;
183             }
184              
185              
186 1     1   5 use vars qw( @stat_tests );
  1         2  
  1         165  
187             @stat_tests = qw( dev ino mode nlink uid gid rdev
188             size atime mtime ctime blksize blocks );
189             {
190             my $i = 0;
191             for my $test (@stat_tests)
192             {
193             my $index = $i++; # to close over
194             my $sub = sub {
195 7     7   16 my $self = _force_object shift;
196              
197 7         13 my @tests = map { Number::Compare->parse_to_perl($_) } @_;
  7         31  
198              
199             $self->_add_rule(
200             {
201             rule => $test,
202             args => \@_,
203             code => 'do { my $val = (stat $path)['
204             . $index
205             . '] || 0;'
206 7         174 . join( '||', map { "(\$val $_)" } @tests ) . ' }',
  7         36  
207             }
208             );
209 7         15 $self;
210             };
211 1     1   6 no strict 'refs';
  1         1  
  1         717  
212             *$test = $sub;
213             }
214             }
215              
216              
217             sub any
218             {
219 8     8 1 13 my $self = _force_object shift;
220 8         21 my @rulesets = @_;
221              
222             $self->_add_rule(
223             {
224             rule => 'any',
225             code => '('
226             . join( ' || ',
227 8         15 map { "( " . $_->_compile( $self->_subs() ) . " )" } @rulesets )
  16         32  
228             . ")",
229             args => \@rulesets,
230             }
231             );
232 8         18 $self;
233             }
234              
235             *or = \&any;
236              
237              
238             sub not
239             {
240 3     3 1 7 my $self = _force_object shift;
241 3         8 my @rulesets = @_;
242              
243             $self->_add_rule(
244             {
245             rule => 'not',
246             args => \@rulesets,
247             code => '('
248             . join( ' && ',
249 3         10 map { "!(" . $_->_compile( $self->_subs() ) . ")" } @_ )
  3         10  
250             . ")",
251             }
252             );
253 3         8 $self;
254             }
255              
256             *none = \¬
257              
258              
259             sub prune ()
260             {
261 4     4 1 7 my $self = _force_object shift;
262              
263 4         13 $self->_add_rule(
264             {
265             rule => 'prune',
266             code => 'do { $self->finder->prune(); 1 }'
267             },
268             );
269              
270 4         9 return $self;
271             }
272              
273              
274             sub discard ()
275             {
276 6     6 1 10 my $self = _force_object shift;
277              
278 6         20 $self->_add_rule(
279             {
280             rule => 'discard',
281             code => '$discarded = 1',
282             }
283             );
284              
285 6         9 return $self;
286             }
287              
288              
289             sub exec
290             {
291 14     14 1 34 my $self = _force_object shift;
292 14         22 my $code = shift;
293              
294 14         46 $self->_add_rule(
295             {
296             rule => 'exec',
297             code => $code,
298             }
299             );
300              
301 14         52 return $self;
302             }
303              
304              
305             sub grep
306             {
307 1     1 1 3 my $self = _force_object shift;
308             my @pattern = map {
309 1         3 ref $_
310             ? ref $_ eq 'ARRAY'
311 2 50       9 ? map { [ ( ref $_ ? $_ : qr/$_/ ) => 0 ] } @$_
  1 100       5  
    50          
312             : [ $_ => 1 ]
313             : [ qr/$_/ => 1 ]
314             } @_;
315              
316             $self->exec(
317             sub {
318 3     3   12 local *FILE;
319 3 50       12 open FILE, $self->finder->item() or return;
320 3         118 local ( $_, $. );
321 3         57 while ()
322             {
323 3         9 for my $p (@pattern)
324             {
325 5         11 my ( $rule, $ret ) = @$p;
326 5 50       149 return $ret
    100          
327             if ref $rule eq 'Regexp'
328             ? /$rule/
329             : $rule->(@_);
330             }
331             }
332 0         0 return;
333             }
334 1         6 );
335             }
336              
337              
338             sub maxdepth
339             {
340 20     20 1 40 my $self = _force_object shift;
341 20         42 $self->_maxdepth(shift);
342 20         46 return $self;
343             }
344              
345             sub mindepth
346             {
347 2     2 1 4 my $self = _force_object shift;
348 2         5 $self->_mindepth(shift);
349 2         3 return $self;
350             }
351              
352              
353             sub relative ()
354             {
355 1     1 1 3 my $self = _force_object shift;
356 1         4 $self->_relative(1);
357              
358 1         2 return $self;
359             }
360              
361              
362       0     sub DESTROY { }
363              
364             sub AUTOLOAD
365             {
366 1 50   1   7 $AUTOLOAD =~ /::not_([^:]*)$/
367             or croak "Can't locate method $AUTOLOAD";
368 1         3 my $method = $1;
369              
370             my $sub = sub {
371 1     1   3 my $self = _force_object shift;
372 1         2 $self->not( $self->new->$method(@_) );
373 1         4 };
374             {
375 1     1   7 no strict 'refs';
  1         1  
  1         592  
  1         2  
376 1         5 *$AUTOLOAD = $sub;
377             }
378 1         2 &$sub;
379             }
380              
381              
382             sub _call_find
383             {
384 37     37   54 my $self = shift;
385 37         47 my $paths = shift;
386              
387 37         206 my $finder = File::Find::Object->new( $self->extras(), @$paths );
388              
389 37         5834 $self->finder($finder);
390              
391 37         62 return;
392             }
393              
394             sub _compile
395             {
396 56     56   76 my $self = shift;
397 56         63 my $subs = shift;
398              
399 56 100       72 return '1' unless @{ $self->rules() };
  56         135  
400              
401             my $code = join " && ", map {
402 81 100       131 if ( ref $_->{code} )
403             {
404 14         24 push @$subs, $_->{code};
405 14         19 "\$subs->[$#{$subs}]->(\@args) # $_->{rule}\n";
  14         54  
406             }
407             else
408             {
409 67         187 "( $_->{code} ) # $_->{rule}\n";
410             }
411 50         71 } @{ $self->rules() };
  50         74  
412              
413 50         143 return $code;
414             }
415              
416             sub in
417             {
418 35     35 1 133 my $self = _force_object shift;
419 35         62 my @paths = @_;
420              
421 35         79 $self->start(@paths);
422              
423 35         47 my @results;
424              
425 35         62 while ( defined( my $match = $self->match() ) )
426             {
427 85         201 push @results, $match;
428             }
429              
430 35         192 return @results;
431             }
432              
433              
434             sub start
435             {
436 37     37 1 50 my $self = _force_object shift;
437 37         61 my @paths = @_;
438              
439 37         73 my $fragment = $self->_compile( $self->_subs() );
440              
441 37         74 my $subs = $self->_subs();
442              
443 37 50 66     93 warn "relative mode handed multiple paths - that's a bit silly\n"
444             if $self->_relative() && @paths > 1;
445              
446 37         77 my $code = 'sub {
447             my $path_obj = shift;
448             my $path = shift;
449              
450             if (!defined($path_obj))
451             {
452             return;
453             }
454              
455             $path =~ s#^(?:\./+)+##;
456             my $path_dir = dirname($path);
457             my $path_base = fileparse($path);
458             my @args = ($path_base, $path_dir, $path);
459             local $_ = $path_base;
460             my $maxdepth = $self->_maxdepth;
461             my $mindepth = $self->_mindepth;
462              
463             my $comps = $path_obj->full_components();
464              
465             my $depth = scalar(@$comps);
466              
467             defined $maxdepth && $depth >= $maxdepth
468             and $self->finder->prune();
469              
470             defined $mindepth && $depth < $mindepth
471             and return;
472              
473             #print "Testing \'$_\'\n";
474              
475             my $discarded;
476             return unless ' . $fragment . ';
477             return if $discarded;
478             return $path;
479             }';
480              
481             #use Data::Dumper;
482             #print Dumper \@subs;
483             #warn "Compiled sub: '$code'\n";
484              
485 37 50       8836 my $callback = eval "$code" or die "compile error '$code' $@";
486              
487 37         198 $self->_match_cb($callback);
488 37         106 $self->_call_find( \@paths );
489              
490 37         72 return $self;
491             }
492              
493              
494             sub match
495             {
496 135     135 1 281 my $self = _force_object shift;
497              
498 135         214 my $finder = $self->finder();
499              
500 135         212 my $match_cb = $self->_match_cb();
501 135         230 my $preproc_cb = $self->extras()->{'preprocess'};
502              
503 135         290 while ( defined( my $next_obj = $finder->next_obj() ) )
504             {
505 265 100 100     57777 if ( defined($preproc_cb) && $next_obj->is_dir() )
506             {
507             $finder->set_traverse_to(
508             $preproc_cb->(
509 7         10 $self, [ @{ $finder->get_current_node_files_list() } ]
  7         16  
510             )
511             );
512             }
513              
514 265 100       7487 if ( defined( my $path = $match_cb->( $next_obj, $next_obj->path() ) ) )
515             {
516 98 100       242 if ( $self->_relative )
517             {
518 1         3 my $comps = $next_obj->full_components();
519 1 50       8 if (@$comps)
520             {
521             return (
522 1 50       10 $next_obj->is_dir()
523             ? File::Spec->catdir(@$comps)
524             : File::Spec->catfile(@$comps)
525             );
526             }
527             }
528             else
529             {
530 97         267 return $path;
531             }
532             }
533              
534             }
535              
536 37         9281 return;
537             }
538              
539             1;
540              
541             __END__