line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Path::Extended::Dir; |
2
|
|
|
|
|
|
|
|
3
|
27
|
|
|
27
|
|
3066
|
use strict; |
|
27
|
|
|
|
|
54
|
|
|
27
|
|
|
|
|
951
|
|
4
|
27
|
|
|
27
|
|
226
|
use warnings; |
|
27
|
|
|
|
|
61
|
|
|
27
|
|
|
|
|
990
|
|
5
|
27
|
|
|
27
|
|
193
|
use base qw( Path::Extended::Entity ); |
|
27
|
|
|
|
|
55
|
|
|
27
|
|
|
|
|
3065
|
|
6
|
27
|
|
|
27
|
|
161
|
use Path::Extended::File; |
|
27
|
|
|
|
|
62
|
|
|
27
|
|
|
|
|
62479
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
sub _initialize { |
9
|
189
|
|
|
189
|
|
420
|
my ($self, @args) = @_; |
10
|
|
|
|
|
|
|
|
11
|
189
|
100
|
|
|
|
1408
|
my $dir = @args ? File::Spec->catdir( @args ) : File::Spec->curdir; |
12
|
|
|
|
|
|
|
|
13
|
189
|
|
|
|
|
2239
|
$self->{_stringify_absolute} = 1; # always true for ::Extended::Dir |
14
|
189
|
|
|
|
|
335
|
$self->{is_dir} = 1; |
15
|
189
|
|
|
|
|
721
|
$self->_set_path($dir); |
16
|
|
|
|
|
|
|
|
17
|
189
|
|
|
|
|
760
|
$self; |
18
|
|
|
|
|
|
|
} |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
sub new_from_file { |
21
|
0
|
|
|
0
|
1
|
0
|
my ($class, $file) = @_; |
22
|
|
|
|
|
|
|
|
23
|
0
|
|
|
|
|
0
|
require File::Basename; |
24
|
0
|
|
|
|
|
0
|
my $dir = File::Basename::dirname( $file ); |
25
|
|
|
|
|
|
|
|
26
|
0
|
|
|
|
|
0
|
my $self = $class->new( $dir ); |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
sub _parts { |
30
|
41
|
|
|
41
|
|
64
|
my ($self, $abs) = @_; |
31
|
|
|
|
|
|
|
|
32
|
41
|
100
|
|
|
|
160
|
my $path = $abs ? $self->_absolute : $self->path; |
33
|
41
|
|
|
|
|
406
|
my ($vol, $dir, $file) = File::Spec->splitpath( $path ); |
34
|
41
|
|
|
|
|
234
|
return split '/', "$dir$file"; |
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
sub basename { |
38
|
8
|
|
|
8
|
1
|
30
|
my $self = shift; |
39
|
|
|
|
|
|
|
|
40
|
8
|
|
|
|
|
29
|
return ($self->_parts)[-1]; |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
sub open { |
44
|
54
|
|
|
54
|
1
|
116
|
my $self = shift; |
45
|
|
|
|
|
|
|
|
46
|
54
|
100
|
|
|
|
197
|
$self->close if $self->is_open; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
opendir my $dh, $self->_absolute |
49
|
54
|
100
|
|
|
|
452
|
or do { $self->log( error => "Can't open $self: $!" ); return; }; |
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
21
|
|
50
|
|
|
|
|
|
|
|
51
|
53
|
100
|
100
|
|
|
463
|
return $dh if $self->{_compat} && defined wantarray; |
52
|
|
|
|
|
|
|
|
53
|
36
|
|
|
|
|
75
|
$self->{handle} = $dh; |
54
|
|
|
|
|
|
|
|
55
|
36
|
|
|
|
|
130
|
$self; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
sub close { |
59
|
53
|
|
|
53
|
1
|
83
|
my $self = shift; |
60
|
|
|
|
|
|
|
|
61
|
53
|
100
|
|
|
|
238
|
if ( my $dh = delete $self->{handle} ) { |
62
|
36
|
|
|
|
|
446
|
closedir $dh; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
sub read { |
67
|
24
|
|
|
24
|
1
|
425
|
my $self = shift; |
68
|
|
|
|
|
|
|
|
69
|
24
|
100
|
|
|
|
62
|
return unless $self->is_open; |
70
|
|
|
|
|
|
|
|
71
|
23
|
|
|
|
|
73
|
my $dh = $self->_handle; |
72
|
23
|
|
|
|
|
230
|
readdir $dh; |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
sub seek { |
76
|
2
|
|
|
2
|
1
|
441
|
my ($self, $pos) = @_; |
77
|
|
|
|
|
|
|
|
78
|
2
|
100
|
|
|
|
8
|
return unless $self->is_open; |
79
|
|
|
|
|
|
|
|
80
|
1
|
|
|
|
|
5
|
my $dh = $self->_handle; |
81
|
1
|
|
50
|
|
|
16
|
seekdir $dh, $pos || 0; |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub tell { |
85
|
6
|
|
|
6
|
1
|
15
|
my $self = shift; |
86
|
|
|
|
|
|
|
|
87
|
6
|
100
|
|
|
|
16
|
return unless $self->is_open; |
88
|
|
|
|
|
|
|
|
89
|
5
|
|
|
|
|
20
|
my $dh = $self->_handle; |
90
|
5
|
|
|
|
|
30
|
telldir $dh; |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
sub rewind { |
94
|
2
|
|
|
2
|
1
|
5
|
my $self = shift; |
95
|
|
|
|
|
|
|
|
96
|
2
|
100
|
|
|
|
7
|
return unless $self->is_open; |
97
|
|
|
|
|
|
|
|
98
|
1
|
|
|
|
|
4
|
my $dh = $self->_handle; |
99
|
1
|
|
|
|
|
12
|
rewinddir $dh; |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
sub find { |
103
|
5
|
|
|
5
|
1
|
1925
|
my ($self, $rule, %options) = @_; |
104
|
|
|
|
|
|
|
|
105
|
5
|
|
|
|
|
24
|
$self->_find( file => $rule, %options ); |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
sub find_dir { |
109
|
3
|
|
|
3
|
1
|
358
|
my ($self, $rule, %options) = @_; |
110
|
|
|
|
|
|
|
|
111
|
3
|
|
|
|
|
14
|
$self->_find( directory => $rule, %options ); |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
sub _find { |
115
|
9
|
|
|
9
|
|
24
|
my ($self, $type, $rule, %options) = @_; |
116
|
|
|
|
|
|
|
|
117
|
9
|
100
|
|
|
|
45
|
return unless $type =~ /^(?:directory|file)$/; |
118
|
|
|
|
|
|
|
|
119
|
8
|
|
|
|
|
1988
|
require File::Find::Rule; |
120
|
|
|
|
|
|
|
|
121
|
10
|
|
|
|
|
28
|
my @items = grep { $_->_relative($self->_absolute) !~ m{/\.} } |
|
10
|
|
|
|
|
4736
|
|
122
|
8
|
|
|
|
|
17283
|
map { $self->_related( $type, $_ ) } |
123
|
|
|
|
|
|
|
File::Find::Rule->$type->name($rule)->in($self->_absolute); |
124
|
|
|
|
|
|
|
|
125
|
8
|
100
|
|
|
|
1482
|
if ( $options{callback} ) { |
126
|
2
|
|
|
|
|
7
|
@items = $options{callback}->( @items ); |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
8
|
|
|
|
|
41
|
return @items; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
sub rmdir { |
133
|
29
|
|
|
29
|
1
|
12810
|
my ($self, @args) = @_; |
134
|
|
|
|
|
|
|
|
135
|
29
|
50
|
|
|
|
156
|
$self->close if $self->is_open; |
136
|
|
|
|
|
|
|
|
137
|
29
|
100
|
|
|
|
118
|
if ( $self->exists ) { |
138
|
28
|
|
|
|
|
180
|
require File::Path; |
139
|
28
|
|
|
|
|
98
|
eval { File::Path::rmtree( $self->_absolute, @args ); 1 } |
|
28
|
|
|
|
|
146
|
|
140
|
28
|
50
|
|
|
|
57
|
or do { my $err = $@; $self->log( error => $err ); return; }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
141
|
|
|
|
|
|
|
} |
142
|
29
|
|
|
|
|
261
|
$self; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
*rmtree = *remove = \&rmdir; |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
sub mkdir { |
148
|
47
|
|
|
47
|
1
|
135
|
my $self = shift; |
149
|
|
|
|
|
|
|
|
150
|
47
|
100
|
|
|
|
240
|
unless ( $self->exists ) { |
151
|
46
|
|
|
|
|
303
|
require File::Path; |
152
|
46
|
|
|
|
|
148
|
eval { File::Path::mkpath( $self->_absolute ); 1 } |
|
46
|
|
|
|
|
197
|
|
153
|
46
|
50
|
|
|
|
123
|
or do { my $err = $@; $self->log( error => $err ); return; }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
154
|
|
|
|
|
|
|
} |
155
|
47
|
|
|
|
|
144
|
$self; |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
*mkpath = \&mkdir; |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
sub next { |
161
|
20
|
|
|
20
|
1
|
1155
|
my $self = shift; |
162
|
|
|
|
|
|
|
|
163
|
20
|
100
|
|
|
|
61
|
$self->open unless $self->is_open; |
164
|
20
|
|
|
|
|
57
|
my $next = $self->read; |
165
|
20
|
100
|
|
|
|
58
|
unless ( defined $next ) { |
166
|
4
|
|
|
|
|
20
|
$self->close; |
167
|
4
|
|
|
|
|
19
|
return; |
168
|
|
|
|
|
|
|
} |
169
|
16
|
100
|
|
|
|
47
|
if ( -d File::Spec->catdir( $self->_absolute, $next ) ) { |
170
|
11
|
|
|
|
|
42
|
return $self->_related( dir => $next ); |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
else { |
173
|
5
|
|
|
|
|
33
|
return $self->_related( file => $next ); |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
50
|
|
|
50
|
1
|
238
|
sub file { shift->_related( file => @_ ); } |
178
|
30
|
|
|
30
|
1
|
651
|
sub subdir { shift->_related( dir => @_ ); } |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub file_or_dir { |
181
|
3
|
|
|
3
|
1
|
11
|
my ($self, @args) = @_; |
182
|
|
|
|
|
|
|
|
183
|
3
|
|
|
|
|
18
|
my $file = $self->_related( file => @args ); |
184
|
3
|
100
|
|
|
|
12
|
return $self->_related( dir => @args ) if -d $file->_absolute; |
185
|
2
|
|
|
|
|
10
|
return $file; |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
sub dir_or_file { |
189
|
3
|
|
|
3
|
1
|
7
|
my ($self, @args) = @_; |
190
|
|
|
|
|
|
|
|
191
|
3
|
|
|
|
|
13
|
my $dir = $self->_related( dir => @args ); |
192
|
3
|
100
|
|
|
|
10
|
return $self->_related( file => @args ) if -f $dir->_absolute; |
193
|
2
|
|
|
|
|
8
|
return $dir; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub children { |
197
|
45
|
|
|
45
|
1
|
124
|
my ($self, %options) = @_; |
198
|
|
|
|
|
|
|
|
199
|
45
|
50
|
|
|
|
117
|
my $dh = $self->open or Carp::croak "Can't open directory $self: $!"; |
200
|
|
|
|
|
|
|
|
201
|
45
|
|
|
|
|
263
|
my @children; |
202
|
45
|
|
|
|
|
473
|
while (defined(my $entry = readdir $dh)) { |
203
|
178
|
100
|
100
|
|
|
1434
|
next if (!$options{all} && ( $entry eq '.' || $entry eq '..' )); |
|
|
|
33
|
|
|
|
|
204
|
88
|
100
|
|
|
|
253
|
my $type = ( -d File::Spec->catdir($self->_absolute, $entry) ) |
205
|
|
|
|
|
|
|
? 'dir' : 'file'; |
206
|
88
|
|
|
|
|
347
|
my $child = $self->_related( $type => $entry ); |
207
|
88
|
100
|
66
|
|
|
286
|
if ($options{prune} or $options{no_hidden}) { |
208
|
76
|
100
|
|
|
|
226
|
if (ref $options{prune} eq 'Regexp') { |
|
|
100
|
|
|
|
|
|
209
|
6
|
100
|
|
|
|
30
|
next if $entry =~ /$options{prune}/; |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
elsif (ref $options{prune} eq 'CODE') { |
212
|
6
|
100
|
|
|
|
17
|
next if $options{prune}->($child); |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
else { |
215
|
64
|
100
|
|
|
|
168
|
next if $entry =~ /^\./; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
} |
218
|
83
|
|
|
|
|
355
|
push @children, $child; |
219
|
|
|
|
|
|
|
} |
220
|
45
|
|
|
|
|
128
|
$self->close; |
221
|
45
|
|
|
|
|
533
|
return @children; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
sub recurse { # adapted from Path::Class::Dir |
225
|
11
|
|
|
11
|
1
|
7446
|
my $self = shift; |
226
|
11
|
|
|
|
|
71
|
my %opts = (preorder => 1, depthfirst => 0, prune => 1, @_); |
227
|
|
|
|
|
|
|
|
228
|
11
|
50
|
|
|
|
44
|
my $callback = $opts{callback} |
229
|
|
|
|
|
|
|
or Carp::croak "Must provide a 'callback' parameter to recurse()"; |
230
|
|
|
|
|
|
|
|
231
|
11
|
|
|
|
|
28
|
my @queue = ($self); |
232
|
|
|
|
|
|
|
|
233
|
11
|
|
|
|
|
15
|
my $visit_entry; |
234
|
|
|
|
|
|
|
my $visit_dir = |
235
|
|
|
|
|
|
|
$opts{depthfirst} && $opts{preorder} |
236
|
|
|
|
|
|
|
? sub { |
237
|
10
|
|
|
10
|
|
14
|
my $dir = shift; |
238
|
10
|
|
|
|
|
28
|
$callback->($dir); |
239
|
10
|
|
|
|
|
64
|
unshift @queue, $dir->children( prune => $opts{prune} ); |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
: $opts{preorder} |
242
|
|
|
|
|
|
|
? sub { |
243
|
23
|
|
|
23
|
|
32
|
my $dir = shift; |
244
|
23
|
|
|
|
|
52
|
$callback->($dir); |
245
|
23
|
|
|
|
|
292
|
push @queue, $dir->children( prune => $opts{prune} ); |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
: sub { |
248
|
10
|
|
|
10
|
|
12
|
my $dir = shift; |
249
|
10
|
|
|
|
|
32
|
$visit_entry->($_) for $dir->children( prune => $opts{prune} ); |
250
|
10
|
|
|
|
|
73
|
$callback->($dir); |
251
|
11
|
100
|
100
|
|
|
315
|
}; |
|
|
100
|
|
|
|
|
|
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
$visit_entry = sub { |
254
|
90
|
|
|
90
|
|
133
|
my $entry = shift; |
255
|
90
|
100
|
|
|
|
282
|
if ($entry->is_dir) { $visit_dir->($entry) } |
|
43
|
|
|
|
|
87
|
|
256
|
47
|
|
|
|
|
117
|
else { $callback->($entry) } |
257
|
11
|
|
|
|
|
45
|
}; |
258
|
|
|
|
|
|
|
|
259
|
11
|
|
|
|
|
35
|
while (@queue) { |
260
|
74
|
|
|
|
|
528
|
$visit_entry->( shift @queue ); |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
sub volume { |
265
|
11
|
|
|
11
|
1
|
16
|
my $self = shift; |
266
|
|
|
|
|
|
|
|
267
|
11
|
|
|
|
|
42
|
my ($vol) = File::Spec->splitpath( $self->path ); |
268
|
11
|
|
|
|
|
48
|
return $vol; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
sub subsumes { |
272
|
11
|
|
|
11
|
1
|
33
|
my ($self, $other) = @_; |
273
|
|
|
|
|
|
|
|
274
|
11
|
50
|
|
|
|
32
|
Carp::croak "No second entity given to subsumes()" unless $other; |
275
|
11
|
|
|
|
|
45
|
my $class = $self->_class('dir'); |
276
|
11
|
100
|
|
|
|
90
|
$other = $class->new($other) unless UNIVERSAL::isa($other, $class); |
277
|
11
|
50
|
|
|
|
52
|
$other = $other->dir unless $other->is_dir; |
278
|
|
|
|
|
|
|
|
279
|
11
|
50
|
|
|
|
49
|
if ( $self->volume ) { |
280
|
0
|
0
|
|
|
|
0
|
return 0 unless $other->volume eq $self->volume; |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
11
|
|
|
|
|
40
|
my @my_parts = $self->_parts(1); |
284
|
11
|
|
|
|
|
31
|
my @other_parts = $other->_parts(1); |
285
|
|
|
|
|
|
|
|
286
|
11
|
50
|
|
|
|
38
|
return 0 if @my_parts > @other_parts; |
287
|
|
|
|
|
|
|
|
288
|
11
|
|
|
|
|
19
|
my $i = 0; |
289
|
11
|
|
|
|
|
33
|
while ( $i < @my_parts ) { |
290
|
45
|
100
|
|
|
|
131
|
return 0 unless $my_parts[$i] eq $other_parts[$i]; |
291
|
41
|
|
|
|
|
84
|
$i++; |
292
|
|
|
|
|
|
|
} |
293
|
7
|
|
|
|
|
61
|
return 1; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
sub contains { |
297
|
2
|
|
|
2
|
1
|
5
|
my ($self, $other) = @_; |
298
|
2
|
|
66
|
|
|
10
|
return !!(-d $self and (-e $other or -l $other) and $self->subsumes($other)); |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
1; |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
__END__ |