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

package Path::Extended::Dir;

use strict;
use warnings;
use base qw( Path::Extended::Entity );
use Path::Extended::File;

sub _initialize {
  my ($self, @args) = @_;

  my $dir = @args ? File::Spec->catdir( @args ) : File::Spec->curdir;

  $self->{_stringify_absolute} = 1; # always true for ::Extended::Dir
  $self->{is_dir}    = 1;
  $self->_set_path($dir);

  $self;
}

sub new_from_file {
  my ($class, $file) = @_;

  require File::Basename;
  my $dir = File::Basename::dirname( $file );

  my $self = $class->new( $dir );
}

sub _parts {
  my ($self, $abs) = @_;

  my $path = $abs ? $self->_absolute : $self->path;
  my ($vol, $dir, $file) = File::Spec->splitpath( $path );
  return split '/', "$dir$file";
}

sub basename {
  my $self = shift;

  return ($self->_parts)[-1];
}

sub open {
  my $self = shift;

  $self->close if $self->is_open;

  opendir my $dh, $self->_absolute
    or do { $self->log( error => "Can't open $self: $!" ); return; };

  return $dh if $self->{_compat} && defined wantarray;

  $self->{handle} = $dh;

  $self;
}

sub close {
  my $self = shift;

  if ( my $dh = delete $self->{handle} ) {
    closedir $dh;
  }
}

sub read {
  my $self = shift;

  return unless $self->is_open;

  my $dh = $self->_handle;
  readdir $dh;
}

sub seek {
  my ($self, $pos) = @_;

  return unless $self->is_open;

  my $dh = $self->_handle;
  seekdir $dh, $pos || 0;
}

sub tell {
  my $self = shift;

  return unless $self->is_open;

  my $dh = $self->_handle;
  telldir $dh;
}

sub rewind {
  my $self = shift;

  return unless $self->is_open;

  my $dh = $self->_handle;
  rewinddir $dh;
}

sub find {
  my ($self, $rule, %options) = @_;

  $self->_find( file => $rule, %options );
}

sub find_dir {
  my ($self, $rule, %options) = @_;

  $self->_find( directory => $rule, %options );
}

sub _find {
  my ($self, $type, $rule, %options) = @_;

  return unless $type =~ /^(?:directory|file)$/;

  require File::Find::Rule;

  my @items = grep { $_->_relative($self->_absolute) !~ m{/\.} }
              map  { $self->_related( $type, $_ ) }
              File::Find::Rule->$type->name($rule)->in($self->_absolute);

  if ( $options{callback} ) {
    @items = $options{callback}->( @items );
  }

  return @items;
}

sub rmdir {
  my ($self, @args) = @_;

  $self->close if $self->is_open;

  if ( $self->exists ) {
    require File::Path;
    eval { File::Path::rmtree( $self->_absolute, @args ); 1 }
      or do { my $err = $@; $self->log( error => $err ); return; };
  }
  $self;
}

*rmtree = *remove = \&rmdir;

sub mkdir {
  my $self = shift;

  unless ( $self->exists ) {
    require File::Path;
    eval { File::Path::mkpath( $self->_absolute ); 1 }
      or do { my $err = $@; $self->log( error => $err ); return; };
  }
  $self;
}

*mkpath = \&mkdir;

sub next {
   my $self = shift;

  $self->open unless $self->is_open;
  my $next = $self->read;
  unless ( defined $next ) {
    $self->close;
    return;
  }
  if ( -d File::Spec->catdir( $self->_absolute, $next ) ) {
    return $self->_related( dir => $next );
  }
  else {
    return $self->_related( file => $next );
  }
}

sub file   { shift->_related( file => @_ ); }
sub subdir { shift->_related( dir  => @_ ); }

sub file_or_dir {
  my ($self, @args) = @_;

  my $file = $self->_related( file => @args );
  return $self->_related( dir => @args ) if -d $file->_absolute;
  return $file;
}

sub dir_or_file {
  my ($self, @args) = @_;

  my $dir = $self->_related( dir => @args );
  return $self->_related( file => @args ) if -f $dir->_absolute;
  return $dir;
}

sub children {
  my ($self, %options) = @_;

  my $dh = $self->open or Carp::croak "Can't open directory $self: $!";

  my @children;
  while (defined(my $entry = readdir $dh)) {
    next if (!$options{all} && ( $entry eq '.' || $entry eq '..' ));
    my $type = ( -d File::Spec->catdir($self->_absolute, $entry) )
               ? 'dir' : 'file';
    my $child = $self->_related( $type => $entry );
    if ($options{prune} or $options{no_hidden}) {
      if (ref $options{prune} eq 'Regexp') {
        next if $entry =~ /$options{prune}/;
      }
      elsif (ref $options{prune} eq 'CODE') {
        next if $options{prune}->($child);
      }
      else {
        next if $entry =~ /^\./;
      }
    }
    push @children, $child;
  }
  $self->close;
  return @children;
}

sub recurse { # adapted from Path::Class::Dir
  my $self = shift;
  my %opts = (preorder => 1, depthfirst => 0, prune => 1, @_);

  my $callback = $opts{callback}
    or Carp::croak "Must provide a 'callback' parameter to recurse()";

  my @queue = ($self);

  my $visit_entry;
  my $visit_dir =
    $opts{depthfirst} && $opts{preorder}
    ? sub {
      my $dir = shift;
      $callback->($dir);
      unshift @queue, $dir->children( prune => $opts{prune} );
    }
    : $opts{preorder}
    ? sub {
      my $dir = shift;
      $callback->($dir);
      push @queue, $dir->children( prune => $opts{prune} );
    }
    : sub {
      my $dir = shift;
      $visit_entry->($_) for $dir->children( prune => $opts{prune} );
      $callback->($dir);
    };

  $visit_entry = sub {
    my $entry = shift;
    if ($entry->is_dir) { $visit_dir->($entry) }
    else { $callback->($entry) }
  };

  while (@queue) {
    $visit_entry->( shift @queue );
  }
}

sub volume {
  my $self = shift;

  my ($vol) = File::Spec->splitpath( $self->path );
  return $vol;
}

sub subsumes {
  my ($self, $other) = @_;

  Carp::croak "No second entity given to subsumes()" unless $other;
  my $class = $self->_class('dir');
  $other = $class->new($other) unless UNIVERSAL::isa($other, $class);
  $other = $other->dir unless $other->is_dir;

  if ( $self->volume ) {
    return 0 unless $other->volume eq $self->volume;
  }

  my @my_parts    = $self->_parts(1);
  my @other_parts = $other->_parts(1);

  return 0 if @my_parts > @other_parts;

  my $i = 0;
  while ( $i < @my_parts ) {
    return 0 unless $my_parts[$i] eq $other_parts[$i];
    $i++;
  }
  return 1;
}

sub contains {
  my ($self, $other) = @_;
  return !!(-d $self and (-e $other or -l $other) and $self->subsumes($other));
}

1;

__END__