1#line 1 2package Path::Class::Dir; 3 4$VERSION = '0.17'; 5 6use strict; 7use Path::Class::File; 8use Path::Class::Entity; 9use Carp(); 10use base qw(Path::Class::Entity); 11 12use IO::Dir (); 13use File::Path (); 14 15sub new { 16 my $self = shift->SUPER::new(); 17 18 # If the only arg is undef, it's probably a mistake. Without this 19 # special case here, we'd return the root directory, which is a 20 # lousy thing to do to someone when they made a mistake. Return 21 # undef instead. 22 return if @_==1 && !defined($_[0]); 23 24 my $s = $self->_spec; 25 26 my $first = (@_ == 0 ? $s->curdir : 27 $_[0] eq '' ? (shift, $s->rootdir) : 28 shift() 29 ); 30 31 ($self->{volume}, my $dirs) = $s->splitpath( $s->canonpath($first) , 1); 32 $self->{dirs} = [$s->splitdir($s->catdir($dirs, @_))]; 33 34 return $self; 35} 36 37sub is_dir { 1 } 38 39sub as_foreign { 40 my ($self, $type) = @_; 41 42 my $foreign = do { 43 local $self->{file_spec_class} = $self->_spec_class($type); 44 $self->SUPER::new; 45 }; 46 47 # Clone internal structure 48 $foreign->{volume} = $self->{volume}; 49 my ($u, $fu) = ($self->_spec->updir, $foreign->_spec->updir); 50 $foreign->{dirs} = [ map {$_ eq $u ? $fu : $_} @{$self->{dirs}}]; 51 return $foreign; 52} 53 54sub stringify { 55 my $self = shift; 56 my $s = $self->_spec; 57 return $s->catpath($self->{volume}, 58 $s->catdir(@{$self->{dirs}}), 59 ''); 60} 61 62sub volume { shift()->{volume} } 63 64sub file { 65 local $Path::Class::Foreign = $_[0]->{file_spec_class} if $_[0]->{file_spec_class}; 66 return Path::Class::File->new(@_); 67} 68 69sub dir_list { 70 my $self = shift; 71 my $d = $self->{dirs}; 72 return @$d unless @_; 73 74 my $offset = shift; 75 if ($offset < 0) { $offset = $#$d + $offset + 1 } 76 77 return wantarray ? @$d[$offset .. $#$d] : $d->[$offset] unless @_; 78 79 my $length = shift; 80 if ($length < 0) { $length = $#$d + $length + 1 - $offset } 81 return @$d[$offset .. $length + $offset - 1]; 82} 83 84sub subdir { 85 my $self = shift; 86 return $self->new($self, @_); 87} 88 89sub parent { 90 my $self = shift; 91 my $dirs = $self->{dirs}; 92 my ($curdir, $updir) = ($self->_spec->curdir, $self->_spec->updir); 93 94 if ($self->is_absolute) { 95 my $parent = $self->new($self); 96 pop @{$parent->{dirs}}; 97 return $parent; 98 99 } elsif ($self eq $curdir) { 100 return $self->new($updir); 101 102 } elsif (!grep {$_ ne $updir} @$dirs) { # All updirs 103 return $self->new($self, $updir); # Add one more 104 105 } elsif (@$dirs == 1) { 106 return $self->new($curdir); 107 108 } else { 109 my $parent = $self->new($self); 110 pop @{$parent->{dirs}}; 111 return $parent; 112 } 113} 114 115sub relative { 116 # File::Spec->abs2rel before version 3.13 returned the empty string 117 # when the two paths were equal - work around it here. 118 my $self = shift; 119 my $rel = $self->_spec->abs2rel($self->stringify, @_); 120 return $self->new( length $rel ? $rel : $self->_spec->curdir ); 121} 122 123sub open { IO::Dir->new(@_) } 124sub mkpath { File::Path::mkpath(shift()->stringify, @_) } 125sub rmtree { File::Path::rmtree(shift()->stringify, @_) } 126 127sub remove { 128 rmdir( shift() ); 129} 130 131sub recurse { 132 my $self = shift; 133 my %opts = (preorder => 1, depthfirst => 0, @_); 134 135 my $callback = $opts{callback} 136 or Carp::croak( "Must provide a 'callback' parameter to recurse()" ); 137 138 my @queue = ($self); 139 140 my $visit_entry; 141 my $visit_dir = 142 $opts{depthfirst} && $opts{preorder} 143 ? sub { 144 my $dir = shift; 145 $callback->($dir); 146 unshift @queue, $dir->children; 147 } 148 : $opts{preorder} 149 ? sub { 150 my $dir = shift; 151 $callback->($dir); 152 push @queue, $dir->children; 153 } 154 : sub { 155 my $dir = shift; 156 $visit_entry->($_) foreach $dir->children; 157 $callback->($dir); 158 }; 159 160 $visit_entry = sub { 161 my $entry = shift; 162 if ($entry->is_dir) { $visit_dir->($entry) } # Will call $callback 163 else { $callback->($entry) } 164 }; 165 166 while (@queue) { 167 $visit_entry->( shift @queue ); 168 } 169} 170 171sub children { 172 my ($self, %opts) = @_; 173 174 my $dh = $self->open or Carp::croak( "Can't open directory $self: $!" ); 175 176 my @out; 177 while (my $entry = $dh->read) { 178 # XXX What's the right cross-platform way to do this? 179 next if (!$opts{all} && ($entry eq '.' || $entry eq '..')); 180 push @out, $self->file($entry); 181 $out[-1] = $self->subdir($entry) if -d $out[-1]; 182 } 183 return @out; 184} 185 186sub next { 187 my $self = shift; 188 unless ($self->{dh}) { 189 $self->{dh} = $self->open or Carp::croak( "Can't open directory $self: $!" ); 190 } 191 192 my $next = $self->{dh}->read; 193 unless (defined $next) { 194 delete $self->{dh}; 195 return undef; 196 } 197 198 # Figure out whether it's a file or directory 199 my $file = $self->file($next); 200 $file = $self->subdir($next) if -d $file; 201 return $file; 202} 203 204sub subsumes { 205 my ($self, $other) = @_; 206 die "No second entity given to subsumes()" unless $other; 207 208 $other = $self->new($other) unless UNIVERSAL::isa($other, __PACKAGE__); 209 $other = $other->dir unless $other->is_dir; 210 211 if ($self->is_absolute) { 212 $other = $other->absolute; 213 } elsif ($other->is_absolute) { 214 $self = $self->absolute; 215 } 216 217 $self = $self->cleanup; 218 $other = $other->cleanup; 219 220 if ($self->volume) { 221 return 0 unless $other->volume eq $self->volume; 222 } 223 224 # The root dir subsumes everything (but ignore the volume because 225 # we've already checked that) 226 return 1 if "@{$self->{dirs}}" eq "@{$self->new('')->{dirs}}"; 227 228 my $i = 0; 229 while ($i <= $#{ $self->{dirs} }) { 230 return 0 if $i > $#{ $other->{dirs} }; 231 return 0 if $self->{dirs}[$i] ne $other->{dirs}[$i]; 232 $i++; 233 } 234 return 1; 235} 236 237sub contains { 238 my ($self, $other) = @_; 239 return !!(-d $self and (-e $other or -l $other) and $self->subsumes($other)); 240} 241 2421; 243__END__ 244 245#line 627 246