File Coverage

lib/Path/Extended/Entity.pm

Criterion	Covered	Total	%
statement	126	140	90.0
branch	45	58	77.5
condition	18	24	75.0
subroutine	37	40	92.5
pod	19	19	100.0
total	245	281	87.1

package Path::Extended::Entity;

use strict;
use warnings;
use Carp ();
use File::Spec;
use Log::Dump;
use Scalar::Util qw( blessed );

use overload
  '""'   => sub { shift->path },
  'cmp'  => sub { return "$_[0]" cmp "$_[1]" },
  'bool' => sub { shift->_boolify },
  '*{}'  => sub { shift->_handle };

sub new {
  my $class = shift;
  my $self  = bless {}, $class;

  $self->_initialize(@_) or return;

  $self;
}

sub _initialize {1}
sub _boolify {1}

sub _class {
  my ($self, $type) = @_;
  my $class = ref $self;
  $class =~ s/::(?:File|Dir|Entity)$//;
  return $class unless $type;
  return $class.'::'.($type eq 'file' ? 'File' : 'Dir');
}

sub _set_path {
    my ($self, $path) = @_;
    $self->{input_path} = $self->_unixify($path);
    $self->{abs_path}   = $self->_unixify( File::Spec->rel2abs($path) );

    # respect setting of _attribute when already done
    $self->{_stringify_absolute} ||= File::Spec->file_name_is_absolute($path);
}

sub _related {
  my ($self, $type, @parts) = @_;

  my $class = $self->_class($type);
  eval "require $class" or Carp::croak $@;
  my $item;
  if ( @parts && $parts[0] eq '..' ) { # parent
    require File::Basename;
    $item = $class->new( File::Basename::dirname($self->_absolute) );
  }
  elsif ( @parts && File::Spec->file_name_is_absolute($parts[0]) ) {
    $item = $class->new( @parts );
  }
  else {
    $item = $class->new( $self->_absolute, @parts );
  }
  foreach my $key ( grep /^_/, keys %{ $self } ) {
    $item->{$key} = $self->{$key};
  }
  $item;
}

sub _unixify {
  my ($self, $path) = @_;

  $path =~ s{\\}{/}g if $^O eq 'MSWin32';

  return $path;
}

sub _handle { shift->{handle} }

sub _stringify_absolute {
  my $self = shift;
  $self->{_stringify_absolute} && !$self->{_base} ? 1 : '';
}

# returns the string version of the path
sub path {
  my $self = shift;
  return ( $self->_stringify_absolute ) ? $self->_absolute : $self->_relative;
}

sub stringify { shift->path }

sub is_dir      { shift->{is_dir} }
sub is_open     { shift->{handle} ? 1 : 0 }


sub is_absolute {
  my $self = shift;
  File::Spec->file_name_is_absolute($self->{input_path});
}

sub resolve {
  my $self = shift;
  Carp::croak "$self: $!" unless -e $self->{abs_path};
  # WoP :
  # Cwd::realpath returns the resolved absolute path
  # calling File::Spec->file_name_is_absolute() not necessary
  $self->{abs_path}  = $self->_unixify(Cwd::realpath($self->{abs_path}));
  $self->{_stringify_absolute} = File::Spec->file_name_is_absolute($self->{abs_path});
  $self;
}

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

  my $path = File::Spec->canonpath( $self->{abs_path} );
  if ( $options{native} ) {
    return $path;
  }
  elsif ( $self->{_compat} ) {
    my ($vol, @parts) = File::Spec->splitpath( $path );
    $vol = '' if $Path::Extended::IgnoreVolume;
    return $self->_unixify( File::Spec->catpath($vol, File::Spec->catdir( @parts ), '') );
  }
  else {
    return $self->_unixify($path);
  }
}

sub _relative {
  my $self = shift;
  my $base = @_ % 2 ? shift : undef;
  my %options = @_;

  $base ||= $options{base} || $self->{_base};

  my $path = File::Spec->abs2rel( $self->{abs_path}, $base );
     $path = $self->_unixify($path) unless $options{native};

  $path;
}

sub absolute { shift->_absolute(@_) }
sub relative { shift->_relative(@_) }

sub parent { shift->_related( dir => '..' ); }

sub unlink {
  my $self = shift;

  $self->close if $self->is_open;
  unlink $self->_absolute if $self->exists;
}

sub exists {
  my $self = shift;

  -e $self->_absolute ? 1 : 0;
}

sub is_writable {
  my $self = shift;

  -w $self->_absolute ? 1 : 0;
}

sub is_readable {
  my $self = shift;

  -r $self->_absolute ? 1 : 0;
}

sub copy_to {
  my ($self, $destination) = @_;

  unless ( $destination ) {
    $self->log( fatal => 'requires destination' );
    return;
  }

  my $class = ref $self;
  $destination = $class->new( "$destination" );

  require File::Copy::Recursive;
  File::Copy::Recursive::rcopy( $self->_absolute, $destination->_absolute )
    or do { $self->log( error => "Can't copy $self to $destination: $!" ); return; };

  $self;
}

sub move_to {
  my ($self, $destination) = @_;

  unless ( $destination ) {
    $self->log( fatal => 'requires destination' );
    return;
  }

  my $class = ref $self;
  $destination = $class->new( "$destination" );

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

  require File::Copy::Recursive;
  File::Copy::Recursive::rmove( $self->_absolute, $destination->_absolute )
    or do { $self->log( error => "Can't move $self to $destination: $!" ); return; };

  $self->{abs_path} = $destination->_absolute;

  $self;
}

sub rename_to {
  my ($self, $destination) = @_;

  unless ( $destination ) {
    $self->log( fatal => 'requires destination' );
    return;
  }

  my $class = ref $self;
  $destination = $class->new( "$destination" );

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

  rename $self->_absolute => $destination->_absolute
    or do { $self->log( error => "Can't rename $self to $destination: $!" ); return; };

  $self->{abs_path} = $destination->_absolute;

  $self;
}

sub stat {
  my $self = shift;

  require File::stat;
  File::stat::stat( $self->{handle} || $self->{abs_path} );
}

sub lstat {
  my $self = shift;

  require File::stat;
  File::stat::lstat( $self->{handle} || $self->{abs_path} );
}

1;

__END__