File Coverage

lib/Path/Extended/Dir.pm
Criterion Covered Total %
statement 154 165 93.3
branch 73 84 86.9
condition 15 20 75.0
subroutine 32 33 96.9
pod 22 22 100.0
total 296 324 91.3


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__