File Coverage

lib/Path/Extended/File.pm

Criterion	Covered	Total	%
statement	158	173	91.3
branch	75	90	83.3
condition	24	34	70.5
subroutine	33	33	100.0
pod	19	19	100.0
total	309	349	88.5

package Path::Extended::File;

use strict;
use warnings;
use base qw( Path::Extended::Entity );
use IO::Handle;
use Sub::Install;

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

  my $file = File::Spec->catfile( @args );
  $self->{_stringify_absolute} = 1; # always true for ::Extended::File
  $self->{is_dir}    = 0;
  $self->_set_path($file);
}

sub basename {
  my $self = shift;
  require File::Basename;
  return File::Basename::basename( $self->{abs_path} );
}

sub open {
  my ($self, $mode) = @_;

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

  $mode ||= 'r';

  my $fh;
  if ( $mode =~ /:/ ) {
    open $fh, $mode, $self->_absolute
      or do { $self->log( error => "Can't open $self: $!" ); return; };
  }
  else {
    open $fh, IO::Handle::_open_mode_string($mode), $self->{abs_path}
      or do { $self->log( error => "Can't open $self: $!" ); return; };
  }

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

  $self->{handle} = $fh;

  $self;
}

sub openr { shift->open('r') }
sub openw { shift->open('w') }

sub sysopen {
  my $self = shift;

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

  CORE::sysopen my $fh, $self->_absolute, @_
    or do { $self->log( error => "Can't open $self: $!" ); return; };

  $self->{handle} = $fh;

  $self;
}

sub close {
  my $self = shift;

  if ( my $fh = delete $self->{handle} ) {
    CORE::close $fh;
  }
}

sub binmode {
  my $self = shift;

  return unless $self->is_open;

  my $fh = $self->{handle};

  if ( @_ ) {
    CORE::binmode $fh, shift;
  }
  else {
    CORE::binmode $fh;
  }
}

BEGIN {
  my @io_methods = qw(
    print printf say getline getlines read sysread write syswrite
    autoflush flush printflush getc ungetc truncate blocking
    eof fileno error sync fcntl ioctl
  );

  foreach my $method (@io_methods) {
    Sub::Install::install_sub({
      as   => $method,
      code => sub {
        return unless $_[0]->is_open; shift->{handle}->$method(@_);
      },
    });
  }
}

sub lock_ex { return unless $_[0]->is_open; shift->_lock }
sub lock_sh { return unless $_[0]->is_open; shift->_lock('share') }

sub _lock {
  my ($self, $mode) = @_;

  my $fh = $self->{handle};

  require Fcntl;
  flock $fh, ( $mode && $mode eq 'share' )
    ? Fcntl::LOCK_SH()
    : Fcntl::LOCK_EX();
}

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

  return unless $self->is_open;

  my $fh = $self->{handle};

  seek $fh, $pos, $whence;
}

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

  return unless $self->is_open;

  my $fh = $self->{handle};

  sysseek $fh, $pos, $whence;
}

sub tell {
  my $self = shift;

  return unless $self->is_open;

  my $fh = $self->{handle};

  tell $fh;
}

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

  my $options = ( @args == 1 and ref $args[0] eq 'HASH' )
    ? $args[0]
    : { @args };

  my $iomode = $options->{iomode} || 'r';
  $self->open($iomode);
  unless ( $self->is_open ) {
    $self->log( warn => "Can't read", $self->{abs_path}, $! );
    return;
  }

  $self->binmode if $options->{binmode};
  my @callbacks;
  my $callback = sub {
    my $line = shift;
    for my $subr (@callbacks) { $line = $subr->(local $_ = $line) }
    $line;
  };
  if ( $options->{chomp} ) {
    push @callbacks, sub { my $line = shift; chomp $line; $line };
  }
  if ( $options->{decode} ) {
    require Encode;
    push @callbacks, sub {
      Encode::decode( $options->{decode}, shift )
    };
  }
  if ( $options->{callback} ) {
    push @callbacks, $options->{callback};
  }
  my $filter;
  if ( my $rule = $options->{filter} ) {
    $filter = qr/$rule/;
  }
  $options->{ignore_return_value} = 1 if !defined wantarray;

  # shortcut
  if (!@callbacks and !$filter and !wantarray) {
    my $got = do { local $/; $self->getline };
    $self->close;
    return $got;
  }

  my @lines;
  while( defined (my $line = $self->getline )) {
    $line = $callback->($line);
    next if $filter && $line !~ /$filter/;
    push @lines, $line unless $options->{ignore_return_value};
  }
  $self->close;
  return wantarray ? @lines : join '', @lines;
}

sub grep {  # just a spoonful of sugar
  my ($self, $rule, @args) = @_;

  my $options = ( @args == 1 and ref $args[0] eq 'HASH' )
    ? $args[0]
    : { @args };

  $options->{filter} = $rule;

  $self->slurp($options);
}

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

  my $options = ( @args == 1 and ref $args[0] eq 'HASH' )
    ? $args[0]
    : { @args };

  if ( $options->{mkdir} ) {
    $self->parent->mkdir;
  }
  my $mode = $options->{mode} || $options->{append} ? '>>' : '>';
  $self->open($mode);
  unless ( $self->is_open ) {
    $self->log( warn => "Can't save", $self->_absolute, $! );
    return;
  }

  if ( $options->{lock} ) {
    unless ( $self->lock_ex ) {
      $self->log( warn => "Can't lock", $self->{abs_path}, $! );
      return;
    }
  }
  $self->binmode if $options->{binmode};

  my @callbacks;
  my $callback = sub {
    my $line = shift;
    for my $subr (@callbacks) { $line = $subr->(local $_ = $line) }
    $line
  };
  if ( $options->{encode} ) {
    require Encode;
    push @callbacks, sub {
      Encode::encode( $options->{encode}, shift )
    };
  }
  if ( $options->{callback} ) {
    push @callbacks, $options->{callback};
  }

  $self->print(
    map { $callback->($_) }
    ref $content eq 'ARRAY' ? @{ $content } : $content
  );
  $self->close;

  if ( $options->{mtime} ) {
    $self->mtime( $options->{mtime} );
  }

  $self;
}

sub touch {
  my $self = shift;

  if ( $self->exists ) {
    $self->mtime(time);
  }
  else {
    $self->openw or return;
    $self->close;
  }
  $self;
}

sub size { return -s ( $_[0]->{handle} || $_[0]->{abs_path} ) }

sub mtime {
  my $self = shift;

  return unless $self->exists;

  if ( @_ ) {
    my $mtime = shift;
    utime $mtime, $mtime, $self->_absolute;
  }
  else {
    return $self->stat->mtime;
  }
}

sub remove { shift->unlink(@_) }

1;

__END__