line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
21
|
|
|
21
|
|
860788
|
use 5.008001; |
|
21
|
|
|
|
|
53
|
|
2
|
21
|
|
|
21
|
|
82
|
use strict; |
|
21
|
|
|
|
|
26
|
|
|
21
|
|
|
|
|
388
|
|
3
|
21
|
|
|
21
|
|
72
|
use warnings; |
|
21
|
|
|
|
|
22
|
|
|
21
|
|
|
|
|
923
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package Path::Iterator::Rule; |
6
|
|
|
|
|
|
|
# ABSTRACT: Iterative, recursive file finder |
7
|
|
|
|
|
|
|
our $VERSION = '1.012'; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
# Register warnings category |
10
|
21
|
|
|
21
|
|
82
|
use warnings::register; |
|
21
|
|
|
|
|
23
|
|
|
21
|
|
|
|
|
2535
|
|
11
|
|
|
|
|
|
|
|
12
|
21
|
|
|
21
|
|
75
|
use if $] ge '5.010000', 're', 'regexp_pattern'; |
|
21
|
|
|
|
|
22
|
|
|
21
|
|
|
|
|
111
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
# Dependencies |
15
|
21
|
|
|
21
|
|
3079
|
use Carp (); |
|
21
|
|
|
|
|
25
|
|
|
21
|
|
|
|
|
289
|
|
16
|
21
|
|
|
21
|
|
65
|
use File::Basename (); |
|
21
|
|
|
|
|
23
|
|
|
21
|
|
|
|
|
230
|
|
17
|
21
|
|
|
21
|
|
62
|
use File::Spec (); |
|
21
|
|
|
|
|
25
|
|
|
21
|
|
|
|
|
227
|
|
18
|
21
|
|
|
21
|
|
61
|
use List::Util (); |
|
21
|
|
|
|
|
20
|
|
|
21
|
|
|
|
|
352
|
|
19
|
21
|
|
|
21
|
|
8103
|
use Number::Compare 0.02; |
|
21
|
|
|
|
|
6972
|
|
|
21
|
|
|
|
|
414
|
|
20
|
21
|
|
|
21
|
|
85
|
use Scalar::Util (); |
|
21
|
|
|
|
|
20
|
|
|
21
|
|
|
|
|
224
|
|
21
|
21
|
|
|
21
|
|
8262
|
use Text::Glob (); |
|
21
|
|
|
|
|
11431
|
|
|
21
|
|
|
|
|
353
|
|
22
|
21
|
|
|
21
|
|
8672
|
use Try::Tiny; |
|
21
|
|
|
|
|
20186
|
|
|
21
|
|
|
|
|
4249
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
25
|
|
|
|
|
|
|
# constructors and meta methods |
26
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
sub new { |
29
|
106
|
|
|
106
|
1
|
101490
|
my $class = shift; |
30
|
106
|
100
|
|
|
|
241
|
$class = ref $class if ref $class; |
31
|
106
|
|
|
|
|
453
|
return bless { rules => [] }, $class; |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
sub clone { |
35
|
1
|
|
|
1
|
1
|
4
|
my $self = shift; |
36
|
1
|
|
|
|
|
5
|
return bless _my_clone( {%$self} ), ref $self; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# avoid XS/buggy dependencies for a simple recursive clone; we clone |
40
|
|
|
|
|
|
|
# fully instead of just 'rules' in case we get subclassed and they |
41
|
|
|
|
|
|
|
# add attributes |
42
|
|
|
|
|
|
|
sub _my_clone { |
43
|
3
|
|
|
3
|
|
3
|
my $d = shift; |
44
|
3
|
100
|
|
|
|
8
|
if ( ref $d eq 'HASH' ) { |
|
|
100
|
|
|
|
|
|
45
|
|
|
|
|
|
|
return { |
46
|
1
|
50
|
|
|
|
2
|
map { ; my $v = $d->{$_}; $_ => ( ref($v) ? _my_clone($v) : $v ) } |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
4
|
|
47
|
|
|
|
|
|
|
keys %$d |
48
|
|
|
|
|
|
|
}; |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
elsif ( ref $d eq 'ARRAY' ) { |
51
|
1
|
50
|
|
|
|
2
|
return [ map { ref($_) ? _my_clone($_) : $_ } @$d ]; |
|
1
|
|
|
|
|
3
|
|
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
else { |
54
|
1
|
|
|
|
|
6
|
return $d; |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
sub add_helper { |
59
|
1367
|
|
|
1367
|
0
|
1362
|
my ( $class, $name, $coderef, $skip_negation ) = @_; |
60
|
1367
|
100
|
|
|
|
1881
|
$class = ref $class if ref $class; |
61
|
1367
|
100
|
|
|
|
5459
|
if ( !$class->can($name) ) { |
62
|
21
|
|
|
21
|
|
99
|
no strict 'refs'; ## no critic |
|
21
|
|
|
|
|
26
|
|
|
21
|
|
|
|
|
66899
|
|
63
|
|
|
|
|
|
|
*$name = sub { |
64
|
99
|
|
|
99
|
|
840
|
my $self = shift; |
65
|
99
|
|
|
|
|
185
|
my $rule = $coderef->(@_); |
66
|
99
|
|
|
|
|
189
|
$self->and($rule); |
67
|
1366
|
|
|
|
|
3551
|
}; |
68
|
1366
|
100
|
|
|
|
2235
|
if ( !$skip_negation ) { |
69
|
1156
|
|
|
|
|
5034
|
*{"not_$name"} = sub { |
70
|
7
|
|
|
7
|
|
12
|
my $self = shift; |
71
|
7
|
|
|
|
|
16
|
my $rule = $coderef->(@_); |
72
|
7
|
|
|
|
|
21
|
$self->not($rule); |
73
|
1156
|
|
|
|
|
2027
|
}; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
else { |
77
|
1
|
|
|
|
|
120
|
Carp::croak("Can't add rule '$name' because it conflicts with an existing method"); |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
82
|
|
|
|
|
|
|
# Implementation-specific method; these may be overridden by subclasses |
83
|
|
|
|
|
|
|
# to test/return results of file wrappers like Path::Class or IO::All |
84
|
|
|
|
|
|
|
# or to provide custom error handler, visitors or other features |
85
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub _objectify { |
88
|
92
|
|
|
92
|
|
96
|
my ( $self, $path ) = @_; |
89
|
92
|
|
|
|
|
227
|
return "$path"; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
## We inline this below, but a subclass equivalent would be this: |
93
|
|
|
|
|
|
|
##sub _children { |
94
|
|
|
|
|
|
|
## my $self = shift; |
95
|
|
|
|
|
|
|
## my $path = "" . shift; # stringify objects |
96
|
|
|
|
|
|
|
## opendir( my $dh, $path ); |
97
|
|
|
|
|
|
|
## return map { [ $_, "$path/$_" ] } grep { $_ ne "." && $_ ne ".." } readdir $dh; |
98
|
|
|
|
|
|
|
##} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# The _stringify option controls whether the string form of an object is cached |
101
|
|
|
|
|
|
|
# for iteration control. This is generally a good idea to avoid extra overhead, |
102
|
|
|
|
|
|
|
# but subclasses can override this if necessary |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub _defaults { |
105
|
|
|
|
|
|
|
return ( |
106
|
|
|
|
|
|
|
_stringify => 1, |
107
|
|
|
|
|
|
|
follow_symlinks => 1, |
108
|
|
|
|
|
|
|
depthfirst => 0, |
109
|
|
|
|
|
|
|
sorted => 1, |
110
|
|
|
|
|
|
|
loop_safe => ( $^O eq 'MSWin32' ? 0 : 1 ), # No inode #'s on Windows |
111
|
2
|
|
|
2
|
|
12
|
error_handler => sub { die sprintf( "%s: %s", @_ ) }, |
112
|
75
|
50
|
|
75
|
|
675
|
visitor => undef, |
113
|
|
|
|
|
|
|
); |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
sub _fast_defaults { |
117
|
|
|
|
|
|
|
return ( |
118
|
2
|
|
|
2
|
|
17
|
_stringify => 1, |
119
|
|
|
|
|
|
|
follow_symlinks => 1, |
120
|
|
|
|
|
|
|
depthfirst => -1, |
121
|
|
|
|
|
|
|
sorted => 0, |
122
|
|
|
|
|
|
|
loop_safe => 0, |
123
|
|
|
|
|
|
|
error_handler => undef, |
124
|
|
|
|
|
|
|
visitor => undef, |
125
|
|
|
|
|
|
|
); |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
129
|
|
|
|
|
|
|
# iteration methods |
130
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
sub iter { |
133
|
75
|
|
|
75
|
1
|
77
|
my $self = shift; |
134
|
75
|
|
|
|
|
147
|
$self->_iter( { $self->_defaults }, @_ ); |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
sub iter_fast { |
138
|
2
|
|
|
2
|
1
|
2
|
my $self = shift; |
139
|
2
|
|
|
|
|
5
|
$self->_iter( { $self->_fast_defaults }, @_ ); |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sub _iter { |
143
|
77
|
|
|
77
|
|
80
|
my $self = shift; |
144
|
77
|
|
|
|
|
63
|
my $defaults = shift; |
145
|
77
|
100
|
100
|
|
|
692
|
my $args = |
|
|
100
|
100
|
|
|
|
|
146
|
|
|
|
|
|
|
ref( $_[0] ) && !Scalar::Util::blessed( $_[0] ) ? shift |
147
|
|
|
|
|
|
|
: ref( $_[-1] ) && !Scalar::Util::blessed( $_[-1] ) ? pop |
148
|
|
|
|
|
|
|
: {}; |
149
|
77
|
|
|
|
|
368
|
my %opts = ( %$defaults, %$args ); |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# unroll these for efficiency |
152
|
77
|
|
|
|
|
121
|
my $opt_stringify = $opts{_stringify}; |
153
|
77
|
|
|
|
|
65
|
my $opt_depthfirst = $opts{depthfirst}; |
154
|
77
|
|
|
|
|
78
|
my $opt_follow_symlinks = $opts{follow_symlinks}; |
155
|
77
|
|
|
|
|
65
|
my $opt_sorted = $opts{sorted}; |
156
|
77
|
|
|
|
|
51
|
my $opt_loop_safe = $opts{loop_safe}; |
157
|
77
|
|
|
|
|
70
|
my $opt_error_handler = $opts{error_handler}; |
158
|
77
|
|
|
|
|
73
|
my $opt_relative = $opts{relative}; |
159
|
77
|
|
|
|
|
58
|
my $opt_visitor = $opts{visitor}; |
160
|
77
|
|
|
|
|
65
|
my $has_rules = @{ $self->{rules} }; |
|
77
|
|
|
|
|
104
|
|
161
|
77
|
|
|
|
|
76
|
my $stash = {}; |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
my $opt_report_symlinks = |
164
|
|
|
|
|
|
|
defined( $opts{report_symlinks} ) |
165
|
|
|
|
|
|
|
? $opts{report_symlinks} |
166
|
77
|
100
|
|
|
|
134
|
: $opts{follow_symlinks}; |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
# if not subclassed, we want to inline |
169
|
77
|
|
|
|
|
248
|
my $can_children = $self->can("_children"); |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
# queue structure: flat list in tuples of 4: (object, basename, depth, origin) |
172
|
|
|
|
|
|
|
# if object is arrayref, then that's a special case signal that it |
173
|
|
|
|
|
|
|
# was already of interest and can finally be returned for postorder searches |
174
|
|
|
|
|
|
|
my @queue = |
175
|
|
|
|
|
|
|
map { |
176
|
77
|
100
|
|
|
|
161
|
my $i = $self->_objectify($_); |
|
77
|
|
|
|
|
152
|
|
177
|
77
|
|
|
|
|
574
|
( $i, File::Basename::basename("$_"), 0, $i ) |
178
|
|
|
|
|
|
|
} @_ ? @_ : '.'; |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
return sub { |
181
|
|
|
|
|
|
|
LOOP: { |
182
|
346
|
|
|
346
|
|
266
|
my ( $item, $base, $depth, $origin ) = splice( @queue, 0, 4 ); |
|
574
|
|
|
|
|
879
|
|
183
|
574
|
100
|
|
|
|
982
|
return unless $item; |
184
|
499
|
100
|
|
|
|
738
|
return $item->[0] if ref $item eq 'ARRAY'; # deferred for postorder |
185
|
493
|
100
|
|
|
|
699
|
my $string_item = $opt_stringify ? "$item" : $item; |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
# by default, we're interested in everything and prune nothing |
188
|
493
|
|
|
|
|
433
|
my ( $interest, $prune ) = ( 1, 0 ); |
189
|
|
|
|
|
|
|
|
190
|
493
|
100
|
|
|
|
4248
|
if ( -l $string_item ) { |
191
|
15
|
100
|
|
|
|
23
|
$prune = 1 if !$opt_follow_symlinks; |
192
|
15
|
100
|
|
|
|
20
|
redo LOOP if !$opt_report_symlinks; |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
491
|
100
|
|
|
|
823
|
if ($has_rules) { |
196
|
390
|
|
|
|
|
402
|
local $_ = $item; |
197
|
390
|
|
|
|
|
435
|
$stash->{_depth} = $depth; |
198
|
390
|
100
|
|
|
|
434
|
if ($opt_error_handler) { |
199
|
|
|
|
|
|
|
$interest = |
200
|
383
|
|
|
|
|
7262
|
try { $self->test( $item, $base, $stash ) } |
201
|
383
|
|
|
|
|
1710
|
catch { $opt_error_handler->( $item, $_ ) }; |
|
5
|
|
|
|
|
96
|
|
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
else { |
204
|
7
|
|
|
|
|
9
|
$interest = $self->test( $item, $base, $stash ); |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
# New way to signal prune is returning a reference to a scalar. |
207
|
|
|
|
|
|
|
# Value of the scalar indicates if it should be returned by the |
208
|
|
|
|
|
|
|
# iterator or not |
209
|
388
|
100
|
|
|
|
3443
|
if ( ref $interest eq 'SCALAR' ) { |
210
|
26
|
|
|
|
|
25
|
$prune = 1; |
211
|
26
|
|
|
|
|
28
|
$interest = $$interest; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# if we have a visitor, we call it like a custom rule |
216
|
489
|
100
|
100
|
|
|
798
|
if ( $opt_visitor && $interest ) { |
217
|
10
|
|
|
|
|
8
|
local $_ = $item; |
218
|
10
|
|
|
|
|
10
|
$stash->{_depth} = $depth; |
219
|
10
|
|
|
|
|
18
|
$opt_visitor->( $item, $base, $stash ); |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
# if it's a directory, maybe add children to the queue |
223
|
489
|
100
|
100
|
|
|
6016
|
if ( ( -d $string_item ) |
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
224
|
|
|
|
|
|
|
&& ( !$prune ) |
225
|
|
|
|
|
|
|
&& ( !$opt_loop_safe || $self->_is_unique( $string_item, $stash ) ) ) |
226
|
|
|
|
|
|
|
{ |
227
|
191
|
50
|
|
|
|
1346
|
if ( !-r $string_item ) { |
228
|
0
|
|
|
|
|
0
|
warnings::warnif("Directory '$string_item' is not readable. Skipping it"); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
else { |
231
|
191
|
|
|
|
|
199
|
my @next; |
232
|
191
|
|
|
|
|
218
|
my $depth_p1 = $depth + 1; |
233
|
191
|
100
|
|
|
|
228
|
if ($can_children) { |
234
|
6
|
|
|
|
|
10
|
my @paths = $can_children->( $self, $item ); |
235
|
6
|
100
|
|
|
|
674
|
if ($opt_sorted) { |
236
|
3
|
|
|
|
|
9
|
@paths = sort { "$a->[0]" cmp "$b->[0]" } @paths; |
|
5
|
|
|
|
|
8
|
|
237
|
|
|
|
|
|
|
} |
238
|
6
|
|
|
|
|
5
|
@next = map { ( $_->[1], $_->[0], $depth_p1, $origin ) } @paths; |
|
14
|
|
|
|
|
29
|
|
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
else { |
241
|
185
|
|
|
|
|
2885
|
opendir( my $dh, $string_item ); |
242
|
185
|
100
|
|
|
|
266
|
if ($opt_sorted) { |
243
|
|
|
|
|
|
|
@next = |
244
|
390
|
|
|
|
|
1836
|
map { ( "$string_item/$_", $_, $depth_p1, $origin ) } |
245
|
183
|
100
|
|
|
|
1522
|
sort { $a cmp $b } grep { $_ ne "." && $_ ne ".." } readdir $dh; |
|
298
|
|
|
|
|
319
|
|
|
756
|
|
|
|
|
2155
|
|
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
else { |
248
|
|
|
|
|
|
|
@next = |
249
|
12
|
|
|
|
|
39
|
map { ( "$string_item/$_", $_, $depth_p1, $origin ) } |
250
|
2
|
100
|
|
|
|
14
|
grep { $_ ne "." && $_ ne ".." } readdir $dh; |
|
16
|
|
|
|
|
41
|
|
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
191
|
100
|
|
|
|
394
|
if ($opt_depthfirst) { |
255
|
|
|
|
|
|
|
# for postorder, requeue as reference to signal it can be returned |
256
|
|
|
|
|
|
|
# without being retested |
257
|
25
|
100
|
100
|
|
|
195
|
push @next, |
|
|
100
|
|
|
|
|
|
258
|
|
|
|
|
|
|
[ |
259
|
|
|
|
|
|
|
( |
260
|
|
|
|
|
|
|
$opt_relative |
261
|
|
|
|
|
|
|
? $self->_objectify( File::Spec->abs2rel( $string_item, $origin ) ) |
262
|
|
|
|
|
|
|
: $item |
263
|
|
|
|
|
|
|
) |
264
|
|
|
|
|
|
|
], |
265
|
|
|
|
|
|
|
$base, $depth, $origin |
266
|
|
|
|
|
|
|
if $interest && $opt_depthfirst > 0; |
267
|
25
|
|
|
|
|
67
|
unshift @queue, @next; |
268
|
25
|
100
|
|
|
|
68
|
redo LOOP if $opt_depthfirst > 0; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
else { |
271
|
166
|
|
|
|
|
476
|
push @queue, @next; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
return ( |
276
|
480
|
100
|
|
|
|
1858
|
$opt_relative |
|
|
100
|
|
|
|
|
|
277
|
|
|
|
|
|
|
? $self->_objectify( File::Spec->abs2rel( $string_item, $origin ) ) |
278
|
|
|
|
|
|
|
: $item |
279
|
|
|
|
|
|
|
) if $interest; |
280
|
217
|
|
|
|
|
268
|
redo LOOP; |
281
|
|
|
|
|
|
|
} |
282
|
77
|
|
|
|
|
2696
|
}; |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
sub all { |
286
|
73
|
|
|
73
|
1
|
53385
|
my $self = shift; |
287
|
73
|
|
|
|
|
164
|
return $self->_all( $self->iter(@_) ); |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
sub all_fast { |
291
|
2
|
|
|
2
|
1
|
14400
|
my $self = shift; |
292
|
2
|
|
|
|
|
9
|
return $self->_all( $self->iter_fast(@_) ); |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
sub _all { |
296
|
75
|
|
|
75
|
|
80
|
my $self = shift; |
297
|
75
|
|
|
|
|
65
|
my $iter = shift; |
298
|
75
|
100
|
|
|
|
136
|
if (wantarray) { |
|
|
100
|
|
|
|
|
|
299
|
69
|
|
|
|
|
64
|
my @results; |
300
|
69
|
|
|
|
|
107
|
while ( defined( my $item = $iter->() ) ) { |
301
|
249
|
|
|
|
|
418
|
push @results, $item; |
302
|
|
|
|
|
|
|
} |
303
|
69
|
|
|
|
|
206
|
return @results; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
elsif ( defined wantarray ) { |
306
|
1
|
|
|
|
|
1
|
my $count = 0; |
307
|
1
|
|
|
|
|
2
|
$count++ while defined $iter->(); |
308
|
1
|
|
|
|
|
2
|
return $count; |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
else { |
311
|
5
|
|
|
|
|
11
|
1 while defined $iter->(); |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
316
|
|
|
|
|
|
|
# logic methods |
317
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
sub and { |
320
|
135
|
|
|
135
|
1
|
123
|
my $self = shift; |
321
|
135
|
|
|
|
|
92
|
push @{ $self->{rules} }, $self->_rulify(@_); |
|
135
|
|
|
|
|
348
|
|
322
|
134
|
|
|
|
|
303
|
return $self; |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
sub or { |
326
|
9
|
|
|
9
|
1
|
9
|
my $self = shift; |
327
|
9
|
|
|
|
|
17
|
my @rules = $self->_rulify(@_); |
328
|
|
|
|
|
|
|
my $coderef = sub { |
329
|
58
|
|
|
58
|
|
36
|
my ( $result, $prune ); |
330
|
58
|
|
|
|
|
50
|
for my $rule (@rules) { |
331
|
113
|
|
|
|
|
136
|
$result = $rule->(@_); |
332
|
|
|
|
|
|
|
# once any rule says to prune, we remember that |
333
|
113
|
|
100
|
|
|
326
|
$prune ||= ref($result) eq 'SCALAR'; |
334
|
|
|
|
|
|
|
# extract whether constraint was met |
335
|
113
|
100
|
|
|
|
130
|
$result = $$result if ref($result) eq 'SCALAR'; |
336
|
|
|
|
|
|
|
# shortcut if met, propagating prune state |
337
|
113
|
100
|
|
|
|
183
|
return ( $prune ? \1 : 1 ) if $result; |
|
|
100
|
|
|
|
|
|
338
|
|
|
|
|
|
|
} |
339
|
35
|
100
|
|
|
|
112
|
return ( $prune ? \$result : $result ) |
340
|
|
|
|
|
|
|
; # may or may not be met, but propagate prune state |
341
|
9
|
|
|
|
|
24
|
}; |
342
|
9
|
|
|
|
|
14
|
return $self->and($coderef); |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
sub not { |
346
|
8
|
|
|
8
|
1
|
10
|
my $self = shift; |
347
|
8
|
|
|
|
|
16
|
my $obj = $self->new->and(@_); |
348
|
|
|
|
|
|
|
my $coderef = sub { |
349
|
38
|
|
|
38
|
|
56
|
my $result = $obj->test(@_); |
350
|
38
|
100
|
|
|
|
104
|
return ref($result) ? \!$$result : !$result; # invert, but preserve prune |
351
|
8
|
|
|
|
|
24
|
}; |
352
|
8
|
|
|
|
|
16
|
return $self->and($coderef); |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
sub skip { |
356
|
4
|
|
|
4
|
1
|
16
|
my $self = shift; |
357
|
4
|
|
|
|
|
5
|
my @rules = @_; |
358
|
4
|
|
|
|
|
5
|
my $obj = $self->new->or(@rules); |
359
|
|
|
|
|
|
|
my $coderef = sub { |
360
|
26
|
|
|
26
|
|
33
|
my $result = $obj->test(@_); |
361
|
26
|
|
|
|
|
21
|
my ( $prune, $interest ); |
362
|
26
|
100
|
|
|
|
37
|
if ( ref($result) eq 'SCALAR' ) { |
363
|
|
|
|
|
|
|
# test told us to prune, so make that sticky |
364
|
|
|
|
|
|
|
# and also skip it |
365
|
3
|
|
|
|
|
4
|
$prune = 1; |
366
|
3
|
|
|
|
|
3
|
$interest = 0; |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
else { |
369
|
|
|
|
|
|
|
# prune if test was true |
370
|
23
|
|
|
|
|
13
|
$prune = $result; |
371
|
|
|
|
|
|
|
# negate test result |
372
|
23
|
|
|
|
|
21
|
$interest = !$result; |
373
|
|
|
|
|
|
|
} |
374
|
26
|
100
|
|
|
|
55
|
return $prune ? \$interest : $interest; |
375
|
4
|
|
|
|
|
7
|
}; |
376
|
4
|
|
|
|
|
8
|
return $self->and($coderef); |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
sub test { |
380
|
665
|
|
|
665
|
1
|
656
|
my ( $self, $item, $base, $stash ) = @_; |
381
|
665
|
|
|
|
|
399
|
my ( $result, $prune ); |
382
|
665
|
|
|
|
|
435
|
for my $rule ( @{ $self->{rules} } ) { |
|
665
|
|
|
|
|
816
|
|
383
|
816
|
|
100
|
|
|
7021
|
$result = $rule->( $item, $base, $stash ) || 0; |
384
|
812
|
100
|
100
|
|
|
2478
|
if ( !ref($result) && $result eq '0 but true' ) { |
385
|
1
|
|
|
|
|
94
|
Carp::croak("0 but true no longer supported by custom rules"); |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
# once any rule says to prune, we remember that |
388
|
811
|
|
100
|
|
|
1690
|
$prune ||= ref($result) eq 'SCALAR'; |
389
|
|
|
|
|
|
|
# extract whether constraint was met |
390
|
811
|
100
|
|
|
|
927
|
$result = $$result if ref($result) eq 'SCALAR'; |
391
|
|
|
|
|
|
|
# shortcut if not met, propagating prune state |
392
|
811
|
100
|
|
|
|
1804
|
return ( $prune ? \0 : 0 ) if !$result; |
|
|
100
|
|
|
|
|
|
393
|
|
|
|
|
|
|
} |
394
|
248
|
100
|
|
|
|
575
|
return ( $prune ? \1 : 1 ); # all constraints met, but propagate prune state |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
398
|
|
|
|
|
|
|
# private methods |
399
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
sub _rulify { |
402
|
144
|
|
|
144
|
|
151
|
my ( $self, @args ) = @_; |
403
|
144
|
|
|
|
|
107
|
my @rules; |
404
|
144
|
|
|
|
|
191
|
for my $arg (@args) { |
405
|
154
|
|
|
|
|
107
|
my $rule; |
406
|
154
|
100
|
100
|
|
|
615
|
if ( Scalar::Util::blessed($arg) && $arg->isa("Path::Iterator::Rule") ) { |
|
|
100
|
|
|
|
|
|
407
|
25
|
|
|
181
|
|
44
|
$rule = sub { $arg->test(@_) }; |
|
181
|
|
|
|
|
207
|
|
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
elsif ( ref($arg) eq 'CODE' ) { |
410
|
128
|
|
|
|
|
113
|
$rule = $arg; |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
else { |
413
|
1
|
|
|
|
|
178
|
Carp::croak("Rules must be coderef or Path::Iterator::Rule"); |
414
|
|
|
|
|
|
|
} |
415
|
153
|
|
|
|
|
195
|
push @rules, $rule; |
416
|
|
|
|
|
|
|
} |
417
|
143
|
|
|
|
|
207
|
return @rules; |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
sub _is_unique { |
421
|
185
|
|
|
185
|
|
254
|
my ( $self, $string_item, $stash ) = @_; |
422
|
185
|
|
|
|
|
166
|
my $unique_id; |
423
|
185
|
|
|
|
|
308
|
my @st = eval { stat $string_item }; |
|
185
|
|
|
|
|
1431
|
|
424
|
185
|
50
|
|
|
|
380
|
@st = eval { lstat $string_item } unless @st; |
|
0
|
|
|
|
|
0
|
|
425
|
185
|
50
|
|
|
|
252
|
if (@st) { |
426
|
185
|
|
|
|
|
469
|
$unique_id = join( ",", $st[0], $st[1] ); |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
else { |
429
|
0
|
0
|
|
|
|
0
|
my $type = -d $string_item ? 'directory' : 'file'; |
430
|
0
|
|
|
|
|
0
|
warnings::warnif("Could not stat $type '$string_item'"); |
431
|
0
|
|
|
|
|
0
|
$unique_id = $string_item; |
432
|
|
|
|
|
|
|
} |
433
|
185
|
|
|
|
|
893
|
return !$stash->{_seen}{$unique_id}++; |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
437
|
|
|
|
|
|
|
# built-in helpers |
438
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
sub _regexify { |
441
|
42
|
|
|
42
|
|
47
|
my ( $re, $add ) = @_; |
442
|
42
|
|
100
|
|
|
116
|
$add ||= ''; |
443
|
42
|
100
|
|
|
|
113
|
my $new = ref($re) eq 'Regexp' ? $re : Text::Glob::glob_to_regex($re); |
444
|
42
|
100
|
|
|
|
2293
|
return $new unless $add; |
445
|
3
|
|
|
|
|
13
|
my ( $pattern, $flags ) = _split_re($new); |
446
|
3
|
50
|
|
|
|
8
|
my $new_flags = $add ? _reflag( $flags, $add ) : ""; |
447
|
3
|
|
|
|
|
62
|
return qr/$new_flags$pattern/; |
448
|
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
sub _split_re { |
451
|
3
|
|
|
3
|
|
5
|
my $value = shift; |
452
|
3
|
50
|
|
|
|
28
|
if ( $] ge 5.010 ) { |
453
|
3
|
|
|
|
|
12
|
return re::regexp_pattern($value); |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
else { |
456
|
0
|
|
|
|
|
0
|
$value =~ s/^\(\?\^?//; |
457
|
0
|
|
|
|
|
0
|
$value =~ s/\)$//; |
458
|
0
|
|
|
|
|
0
|
my ( $opt, $re ) = split( /:/, $value, 2 ); |
459
|
0
|
|
|
|
|
0
|
$opt =~ s/\-\w+$//; |
460
|
0
|
|
|
|
|
0
|
return ( $re, $opt ); |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
sub _reflag { |
465
|
3
|
|
|
3
|
|
4
|
my ( $orig, $add ) = @_; |
466
|
3
|
|
100
|
|
|
11
|
$orig ||= ""; |
467
|
|
|
|
|
|
|
|
468
|
3
|
50
|
|
|
|
6
|
if ( $] >= 5.014 ) { |
469
|
3
|
|
|
|
|
9
|
return "(?^$orig$add)"; |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
else { |
472
|
0
|
|
|
|
|
0
|
my ( $pos, $neg ) = split /-/, $orig; |
473
|
0
|
|
0
|
|
|
0
|
$pos ||= ""; |
474
|
0
|
|
0
|
|
|
0
|
$neg ||= ""; |
475
|
0
|
|
|
|
|
0
|
$neg =~ s/i//; |
476
|
0
|
0
|
|
|
|
0
|
$neg = "-$neg" if length $neg; |
477
|
0
|
|
|
|
|
0
|
return "(?$add$pos$neg)"; |
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
} |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
# "simple" helpers take no arguments |
482
|
|
|
|
|
|
|
my %simple_helpers = ( |
483
|
|
|
|
|
|
|
directory => sub { -d $_ }, # see also -d => dir below |
484
|
|
|
|
|
|
|
dangling => sub { -l $_ && !stat $_ }, |
485
|
|
|
|
|
|
|
); |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
while ( my ( $k, $v ) = each %simple_helpers ) { |
488
|
|
|
|
|
|
|
__PACKAGE__->add_helper( $k, sub { return $v } ); |
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
sub _generate_name_matcher { |
492
|
33
|
|
|
33
|
|
50
|
my (@patterns) = @_; |
493
|
33
|
100
|
|
|
|
68
|
if ( @patterns > 1 ) { |
494
|
|
|
|
|
|
|
return sub { |
495
|
28
|
|
|
28
|
|
34
|
my $name = "$_[1]"; |
496
|
28
|
100
|
|
|
|
108
|
return ( List::Util::first { $name =~ $_ } @patterns ) ? 1 : 0; |
|
83
|
|
|
|
|
215
|
|
497
|
|
|
|
|
|
|
} |
498
|
4
|
|
|
|
|
22
|
} |
499
|
|
|
|
|
|
|
else { |
500
|
29
|
|
|
|
|
34
|
my $pattern = $patterns[0]; |
501
|
|
|
|
|
|
|
return sub { |
502
|
133
|
|
|
133
|
|
175
|
my $name = "$_[1]"; |
503
|
133
|
100
|
|
|
|
696
|
return $name =~ $pattern ? 1 : 0; |
504
|
|
|
|
|
|
|
} |
505
|
29
|
|
|
|
|
106
|
} |
506
|
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
# "complex" helpers take arguments |
509
|
|
|
|
|
|
|
my %complex_helpers = ( |
510
|
|
|
|
|
|
|
name => sub { |
511
|
|
|
|
|
|
|
Carp::croak("No patterns provided to 'name'") unless @_; |
512
|
|
|
|
|
|
|
_generate_name_matcher( map { _regexify($_) } @_ ); |
513
|
|
|
|
|
|
|
}, |
514
|
|
|
|
|
|
|
iname => sub { |
515
|
|
|
|
|
|
|
Carp::croak("No patterns provided to 'iname'") unless @_; |
516
|
|
|
|
|
|
|
_generate_name_matcher( map { _regexify( $_, "i" ) } @_ ); |
517
|
|
|
|
|
|
|
}, |
518
|
|
|
|
|
|
|
min_depth => sub { |
519
|
|
|
|
|
|
|
Carp::croak("No depth argument given to 'min_depth'") unless @_; |
520
|
|
|
|
|
|
|
my $min_depth = 0+ shift; # if this warns, do here and not on every file |
521
|
|
|
|
|
|
|
return sub { |
522
|
|
|
|
|
|
|
my ( $f, $b, $stash ) = @_; |
523
|
|
|
|
|
|
|
return $stash->{_depth} >= $min_depth; |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
}, |
526
|
|
|
|
|
|
|
max_depth => sub { |
527
|
|
|
|
|
|
|
Carp::croak("No depth argument given to 'max_depth'") unless @_; |
528
|
|
|
|
|
|
|
my $max_depth = 0+ shift; # if this warns, do here and not on every file |
529
|
|
|
|
|
|
|
return sub { |
530
|
|
|
|
|
|
|
my ( $f, $b, $stash ) = @_; |
531
|
|
|
|
|
|
|
return 1 if $stash->{_depth} < $max_depth; |
532
|
|
|
|
|
|
|
return \1 if $stash->{_depth} == $max_depth; |
533
|
|
|
|
|
|
|
return \0; |
534
|
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
}, |
536
|
|
|
|
|
|
|
shebang => sub { |
537
|
|
|
|
|
|
|
Carp::croak("No patterns provided to 'shebang'") unless @_; |
538
|
|
|
|
|
|
|
my @patterns = map { _regexify($_) } @_; |
539
|
|
|
|
|
|
|
return sub { |
540
|
|
|
|
|
|
|
my $f = shift; |
541
|
|
|
|
|
|
|
return unless !-d $f; |
542
|
|
|
|
|
|
|
open my $fh, "<", $f; |
543
|
|
|
|
|
|
|
my $shebang = <$fh>; |
544
|
|
|
|
|
|
|
return unless defined $shebang; |
545
|
|
|
|
|
|
|
return ( List::Util::first { $shebang =~ $_ } @patterns ) ? 1 : 0; |
546
|
|
|
|
|
|
|
}; |
547
|
|
|
|
|
|
|
}, |
548
|
|
|
|
|
|
|
contents_match => sub { |
549
|
|
|
|
|
|
|
my @regexp = @_; |
550
|
|
|
|
|
|
|
my $filter = ':encoding(UTF-8)'; |
551
|
|
|
|
|
|
|
$filter = shift @regexp unless ref $regexp[0]; |
552
|
|
|
|
|
|
|
return sub { |
553
|
|
|
|
|
|
|
my $f = shift; |
554
|
|
|
|
|
|
|
return unless !-d $f; |
555
|
|
|
|
|
|
|
my $contents = do { |
556
|
|
|
|
|
|
|
local $/ = undef; |
557
|
|
|
|
|
|
|
open my $fh, "<$filter", $f; |
558
|
|
|
|
|
|
|
<$fh>; |
559
|
|
|
|
|
|
|
}; |
560
|
|
|
|
|
|
|
for my $re (@regexp) { |
561
|
|
|
|
|
|
|
return 1 if $contents =~ $re; |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
return 0; |
564
|
|
|
|
|
|
|
}; |
565
|
|
|
|
|
|
|
}, |
566
|
|
|
|
|
|
|
line_match => sub { |
567
|
|
|
|
|
|
|
my @regexp = @_; |
568
|
|
|
|
|
|
|
my $filter = ':encoding(UTF-8)'; |
569
|
|
|
|
|
|
|
$filter = shift @regexp unless ref $regexp[0]; |
570
|
|
|
|
|
|
|
return sub { |
571
|
|
|
|
|
|
|
my $f = shift; |
572
|
|
|
|
|
|
|
return unless !-d $f; |
573
|
1
|
|
|
1
|
|
4
|
open my $fh, "<$filter", $f; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
6
|
|
574
|
|
|
|
|
|
|
while ( my $line = <$fh> ) { |
575
|
|
|
|
|
|
|
for my $re (@regexp) { |
576
|
|
|
|
|
|
|
return 1 if $line =~ $re; |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
return 0; |
580
|
|
|
|
|
|
|
}; |
581
|
|
|
|
|
|
|
}, |
582
|
|
|
|
|
|
|
); |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
while ( my ( $k, $v ) = each %complex_helpers ) { |
585
|
|
|
|
|
|
|
__PACKAGE__->add_helper( $k, $v ); |
586
|
|
|
|
|
|
|
} |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
# skip_dirs |
589
|
|
|
|
|
|
|
__PACKAGE__->add_helper( |
590
|
|
|
|
|
|
|
skip_dirs => sub { |
591
|
|
|
|
|
|
|
Carp::croak("No patterns provided to 'skip_dirs'") unless @_; |
592
|
|
|
|
|
|
|
my $name_check = Path::Iterator::Rule->new->name(@_); |
593
|
|
|
|
|
|
|
return sub { |
594
|
|
|
|
|
|
|
return \0 if -d $_[0] && $name_check->test(@_); |
595
|
|
|
|
|
|
|
return 1; # otherwise, like a null rule |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
} => 1 # don't create not_skip_dirs |
598
|
|
|
|
|
|
|
); |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
__PACKAGE__->add_helper( |
601
|
|
|
|
|
|
|
skip_subdirs => sub { |
602
|
|
|
|
|
|
|
Carp::croak("No patterns provided to 'skip_subdirs'") unless @_; |
603
|
|
|
|
|
|
|
my $name_check = Path::Iterator::Rule->new->name(@_); |
604
|
|
|
|
|
|
|
return sub { |
605
|
|
|
|
|
|
|
my ( $f, $b, $stash ) = @_; |
606
|
|
|
|
|
|
|
return \0 if -d $f && $stash->{_depth} && $name_check->test(@_); |
607
|
|
|
|
|
|
|
return 1; # otherwise, like a null rule |
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
} => 1 # don't create not_skip_dirs |
610
|
|
|
|
|
|
|
); |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
# X_tests adapted from File::Find::Rule |
613
|
|
|
|
|
|
|
#<<< do not perltidy this |
614
|
|
|
|
|
|
|
my %X_tests = ( |
615
|
|
|
|
|
|
|
-r => readable => -R => r_readable => |
616
|
|
|
|
|
|
|
-w => writeable => -W => r_writeable => |
617
|
|
|
|
|
|
|
-w => writable => -W => r_writable => |
618
|
|
|
|
|
|
|
-x => executable => -X => r_executable => |
619
|
|
|
|
|
|
|
-o => owned => -O => r_owned => |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
-e => exists => -f => file => |
622
|
|
|
|
|
|
|
-z => empty => -d => dir => |
623
|
|
|
|
|
|
|
-s => nonempty => -l => symlink => |
624
|
|
|
|
|
|
|
=> -p => fifo => |
625
|
|
|
|
|
|
|
-u => setuid => -S => socket => |
626
|
|
|
|
|
|
|
-g => setgid => -b => block => |
627
|
|
|
|
|
|
|
-k => sticky => -c => character => |
628
|
|
|
|
|
|
|
=> -t => tty => |
629
|
|
|
|
|
|
|
-T => ascii => |
630
|
|
|
|
|
|
|
-B => binary => |
631
|
|
|
|
|
|
|
); |
632
|
|
|
|
|
|
|
#>>> |
633
|
|
|
|
|
|
|
|
634
|
|
|
|
|
|
|
while ( my ( $op, $name ) = each %X_tests ) { |
635
|
|
|
|
|
|
|
my $coderef = eval "sub { $op \$_ }"; ## no critic |
636
|
|
|
|
|
|
|
__PACKAGE__->add_helper( $name, sub { return $coderef } ); |
637
|
|
|
|
|
|
|
} |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
my %time_tests = ( -A => accessed => -M => modified => -C => changed => ); |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
while ( my ( $op, $name ) = each %time_tests ) { |
642
|
|
|
|
|
|
|
my $filetest = eval "sub { $op \$_ }"; ## no critic |
643
|
|
|
|
|
|
|
my $coderef = sub { |
644
|
|
|
|
|
|
|
Carp::croak("The '$name' test requires a single argument") unless @_ == 1; |
645
|
|
|
|
|
|
|
my $comparator = Number::Compare->new(shift); |
646
|
|
|
|
|
|
|
return sub { return $comparator->( $filetest->() ) }; |
647
|
|
|
|
|
|
|
}; |
648
|
|
|
|
|
|
|
__PACKAGE__->add_helper( $name, $coderef ); |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
# stat tests adapted from File::Find::Rule |
652
|
|
|
|
|
|
|
my @stat_tests = qw( |
653
|
|
|
|
|
|
|
dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks |
654
|
|
|
|
|
|
|
); |
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
for my $i ( 0 .. $#stat_tests ) { |
657
|
|
|
|
|
|
|
my $name = $stat_tests[$i]; |
658
|
|
|
|
|
|
|
my $coderef = sub { |
659
|
|
|
|
|
|
|
Carp::croak("The '$name' test requires a single argument") unless @_ == 1; |
660
|
|
|
|
|
|
|
my $comparator = Number::Compare->new(shift); |
661
|
|
|
|
|
|
|
return sub { return $comparator->( ( stat($_) )[$i] ) }; |
662
|
|
|
|
|
|
|
}; |
663
|
|
|
|
|
|
|
__PACKAGE__->add_helper( $name, $coderef ); |
664
|
|
|
|
|
|
|
} |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
# VCS rules adapted from File::Find::Rule::VCS |
667
|
|
|
|
|
|
|
my %vcs_rules = ( |
668
|
|
|
|
|
|
|
skip_cvs => sub { |
669
|
|
|
|
|
|
|
return Path::Iterator::Rule->new->skip_dirs('CVS')->not_name(qr/\.\#$/); |
670
|
|
|
|
|
|
|
}, |
671
|
|
|
|
|
|
|
skip_rcs => sub { |
672
|
|
|
|
|
|
|
return Path::Iterator::Rule->new->skip_dirs('RCS')->not_name(qr/,v$/); |
673
|
|
|
|
|
|
|
}, |
674
|
|
|
|
|
|
|
skip_git => sub { |
675
|
|
|
|
|
|
|
return Path::Iterator::Rule->new->skip_dirs('.git'); |
676
|
|
|
|
|
|
|
}, |
677
|
|
|
|
|
|
|
skip_svn => sub { |
678
|
|
|
|
|
|
|
return Path::Iterator::Rule->new->skip_dirs( |
679
|
|
|
|
|
|
|
( $^O eq 'MSWin32' ) ? ( '.svn', '_svn' ) : ('.svn') ); |
680
|
|
|
|
|
|
|
}, |
681
|
|
|
|
|
|
|
skip_bzr => sub { |
682
|
|
|
|
|
|
|
return Path::Iterator::Rule->new->skip_dirs('.bzr'); |
683
|
|
|
|
|
|
|
}, |
684
|
|
|
|
|
|
|
skip_hg => sub { |
685
|
|
|
|
|
|
|
return Path::Iterator::Rule->new->skip_dirs('.hg'); |
686
|
|
|
|
|
|
|
}, |
687
|
|
|
|
|
|
|
skip_darcs => sub { |
688
|
|
|
|
|
|
|
return Path::Iterator::Rule->new->skip_dirs('_darcs'); |
689
|
|
|
|
|
|
|
}, |
690
|
|
|
|
|
|
|
skip_vcs => sub { |
691
|
|
|
|
|
|
|
return Path::Iterator::Rule->new->skip_dirs(qw/.git .bzr .hg _darcs CVS RCS/) |
692
|
|
|
|
|
|
|
->skip_svn->not_name( qr/\.\#$/, qr/,v$/ ); |
693
|
|
|
|
|
|
|
}, |
694
|
|
|
|
|
|
|
); |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
while ( my ( $name, $coderef ) = each %vcs_rules ) { |
697
|
|
|
|
|
|
|
__PACKAGE__->add_helper( $name, $coderef, 1 ); # don't create not_* |
698
|
|
|
|
|
|
|
} |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
# perl rules adapted from File::Find::Rule::Perl |
701
|
|
|
|
|
|
|
my %perl_rules = ( |
702
|
|
|
|
|
|
|
perl_module => sub { return Path::Iterator::Rule->new->file->name('*.pm') }, |
703
|
|
|
|
|
|
|
perl_pod => sub { return Path::Iterator::Rule->new->file->name('*.pod') }, |
704
|
|
|
|
|
|
|
perl_test => sub { return Path::Iterator::Rule->new->file->name('*.t') }, |
705
|
|
|
|
|
|
|
perl_installer => sub { |
706
|
|
|
|
|
|
|
return Path::Iterator::Rule->new->file->name( 'Makefile.PL', 'Build.PL' ); |
707
|
|
|
|
|
|
|
}, |
708
|
|
|
|
|
|
|
perl_script => sub { |
709
|
|
|
|
|
|
|
return Path::Iterator::Rule->new->file->or( |
710
|
|
|
|
|
|
|
Path::Iterator::Rule->new->name('*.pl'), |
711
|
|
|
|
|
|
|
Path::Iterator::Rule->new->shebang(qr/#!.*\bperl\b/), |
712
|
|
|
|
|
|
|
); |
713
|
|
|
|
|
|
|
}, |
714
|
|
|
|
|
|
|
perl_file => sub { |
715
|
|
|
|
|
|
|
return Path::Iterator::Rule->new->or( |
716
|
|
|
|
|
|
|
Path::Iterator::Rule->new->perl_module, Path::Iterator::Rule->new->perl_pod, |
717
|
|
|
|
|
|
|
Path::Iterator::Rule->new->perl_test, Path::Iterator::Rule->new->perl_installer, |
718
|
|
|
|
|
|
|
Path::Iterator::Rule->new->perl_script, |
719
|
|
|
|
|
|
|
); |
720
|
|
|
|
|
|
|
}, |
721
|
|
|
|
|
|
|
); |
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
while ( my ( $name, $coderef ) = each %perl_rules ) { |
724
|
|
|
|
|
|
|
__PACKAGE__->add_helper( $name, $coderef ); |
725
|
|
|
|
|
|
|
} |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
1; |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
# vim: ts=4 sts=4 sw=4 et: |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
__END__ |