local-lib5/lib/perl5/Path/Class/Entity.pm

   1 package Path::Class::Entity;
   2
   3 $VERSION = '0.17';
   4
   5 use strict;
   6 use File::Spec;
   7 use File::stat ();
   8 use Cwd;
   9
  10 use overload
  11   (
  12    q[""] => 'stringify',
  13    'bool' => 'boolify',
  14    fallback => 1,
  15   );
  16
  17 sub new {
  18   my $from = shift;
  19   my ($class, $fs_class) = (ref($from)
  20                             ? (ref $from, $from->{file_spec_class})
  21                             : ($from, $Path::Class::Foreign));
  22   return bless {file_spec_class => $fs_class}, $class;
  23 }
  24
  25 sub is_dir { 0 }
  26
  27 sub _spec_class {
  28   my ($class, $type) = @_;
  29
  30   die "Invalid system type '$type'" unless ($type) = $type =~ /^(\w+)$/;  # Untaint
  31   my $spec = "File::Spec::$type";
  32   eval "require $spec; 1" or die $@;
  33   return $spec;
  34 }
  35
  36 sub new_foreign {
  37   my ($class, $type) = (shift, shift);
  38   local $Path::Class::Foreign = $class->_spec_class($type);
  39   return $class->new(@_);
  40 }
  41
  42 sub _spec { $_[0]->{file_spec_class} || 'File::Spec' }
  43
  44 sub boolify { 1 }
  45
  46 sub is_absolute {
  47   # 5.6.0 has a bug with regexes and stringification that's ticked by
  48   # file_name_is_absolute().  Help it along with an explicit stringify().
  49   $_[0]->_spec->file_name_is_absolute($_[0]->stringify)
  50 }
  51
  52 sub is_relative { ! $_[0]->is_absolute }
  53
  54 sub cleanup {
  55   my $self = shift;
  56   my $cleaned = $self->new( $self->_spec->canonpath($self) );
  57   %$self = %$cleaned;
  58   return $self;
  59 }
  60
  61 sub resolve {
  62   my $self = shift;
  63   my $cleaned = $self->new( Cwd::realpath($self->stringify) );
  64
  65   # realpath() always returns absolute path, kind of annoying
  66   $cleaned = $cleaned->relative if $self->is_relative;
  67
  68   %$self = %$cleaned;
  69   return $self;
  70 }
  71
  72 sub absolute {
  73   my $self = shift;
  74   return $self if $self->is_absolute;
  75   return $self->new($self->_spec->rel2abs($self->stringify, @_));
  76 }
  77
  78 sub relative {
  79   my $self = shift;
  80   return $self->new($self->_spec->abs2rel($self->stringify, @_));
  81 }
  82
  83 sub stat  { File::stat::stat("$_[0]") }
  84 sub lstat { File::stat::lstat("$_[0]") }
  85
  86 1;