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