File Coverage

lib/File/DataClass/IO.pm

Criterion	Covered	Total	%
statement	543	544	100.0
branch	229	272	85.6
condition	134	167	80.8
subroutine	139	139	100.0
pod	105	105	100.0
total	1150	1227	94.2

package File::DataClass::IO;

use 5.010001;

use Cwd                        qw( );
use English                    qw( -no_match_vars );
use Fcntl                      qw( :flock :seek );
use File::Basename               ( );
use File::Copy                   ( );
use File::DataClass::Constants qw( EXCEPTION_CLASS FALSE LOCK_BLOCKING
                                   LOCK_NONBLOCKING NO_UMASK_STACK NUL
                                   PERMS STAT_FIELDS TILDE TRUE );
use File::DataClass::Functions qw( ensure_class_loaded first_char is_arrayref
                                   is_coderef is_hashref is_member is_mswin
                                   is_ntfs thread_id throw );
use File::Spec                   ( );
use File::Spec::Functions      qw( curdir updir );
use IO::Dir;
use IO::File;
use IO::Handle;
use List::Util                 qw( first );
use Scalar::Util               qw( blessed );
use Sub::Install               qw( install_sub );
use Type::Utils                qw( enum );
use Unexpected::Functions      qw( InvocantUndefined PathNotFound Unspecified );
use Unexpected::Types          qw( ArrayRef Bool CodeRef Int Maybe Object
                                   PositiveInt RegexpRef SimpleStr Str );
use Moo;

use namespace::clean -except => [ 'meta' ];
use overload '""'       => sub { $_[ 0 ]->as_string  },
             'bool'     => sub { $_[ 0 ]->as_boolean },
             'fallback' => TRUE;

my $IO_LOCK = enum 'IO_Lock' => [ FALSE, LOCK_BLOCKING, LOCK_NONBLOCKING ];
my $IO_MODE = enum 'IO_Mode' => [ qw( a a+ r r+ w w+ ) ];
my $IO_TYPE = enum 'IO_Type' => [ qw( dir file ) ];

# Attribute constructors
my $_build_dir_pattern = sub {
   my $cd = curdir; my $ud = updir; qr{ \A (?: \Q${cd}\E | \Q${ud}\E ) \z }mx;
};

my $_catfile = sub {
   return File::Spec->catfile( map { defined( $_ ) ? $_ : NUL } @_ );
};

my $_expand_tilde = sub {
  (my $path = $_[ 0 ]) =~ m{ \A ([~] [^/\\]*) .* }mx;

   my ($dir) = glob( $1 ); $path =~ s{ \A ([~] [^/\\]*) }{$dir}mx;

   return $path;
};

my $_coerce_name = sub {
   my $name = shift;

   not defined  $name          and return;
   is_coderef   $name          and $name =  $name->();
   blessed      $name          and $name =  "${name}";
   is_arrayref  $name          and $name =  $_catfile->( @{ $name } );
   first_char   $name eq TILDE and $name =  $_expand_tilde->( $name );
   curdir eq    $name          and $name =  Cwd::getcwd();
   CORE::length $name > 1      and $name =~ s{ [/\\] \z }{}mx;
   return $name;
};

# Public attributes
has 'autoclose'     => is => 'lazy', isa => Bool,           default => TRUE  ;
has 'have_lock'     => is => 'rwp',  isa => Bool,           default => FALSE ;
has 'io_handle'     => is => 'rwp',  isa => Maybe[Object]                    ;
has 'is_open'       => is => 'rwp',  isa => Bool,           default => FALSE ;
has 'mode'          => is => 'rwp',  isa => $IO_MODE | PositiveInt,
   default          => 'r'                                                   ;
has 'name'          => is => 'rwp',  isa => SimpleStr,      default => NUL,
   coerce           => $_coerce_name,                       lazy    => TRUE  ;
has '_perms'        => is => 'rwp',  isa => PositiveInt,    default => PERMS,
   init_arg         => 'perms'                                               ;
has 'reverse'       => is => 'lazy', isa => Bool,           default => FALSE ;
has 'sort'          => is => 'lazy', isa => Bool,           default => TRUE  ;
has 'type'          => is => 'rwp',  isa => Maybe[$IO_TYPE]                  ;

# Private attributes
has '_assert'       => is => 'rw',   isa => Bool,           default => FALSE ;
has '_atomic'       => is => 'rw',   isa => Bool,           default => FALSE ;
has '_atomic_infix' => is => 'rw',   isa => SimpleStr,      default => 'B_*' ;
has '_backwards'    => is => 'rw',   isa => Bool,           default => FALSE ;
has '_block_size'   => is => 'rw',   isa => PositiveInt,    default => 1024  ;
has '_chomp'        => is => 'rw',   isa => Bool,           default => FALSE ;
has '_deep'         => is => 'rw',   isa => Bool,           default => FALSE ;
has '_dir_pattern'  => is => 'lazy', isa => RegexpRef,
   builder          => $_build_dir_pattern                                   ;
has '_filter'       => is => 'rw',   isa => Maybe[CodeRef]                   ;
has '_layers'       => is => 'ro',   isa => ArrayRef[SimpleStr],
   builder          => sub { [] }                                            ;
has '_lock'         => is => 'rw',   isa => $IO_LOCK,       default => FALSE ;
has '_no_follow'    => is => 'rw',   isa => Bool,           default => FALSE ;
has '_separator'    => is => 'rw',   isa => Str,            default => $RS   ;
has '_umask'        => is => 'ro',   isa => ArrayRef[Int],
   builder          => sub { [] }                                            ;

# Construction
my @ARG_NAMES = qw( name mode perms );

my $_clone_one_of_us = sub {
   my ($self, $params) = @_;

   $self->autoclose; $self->reverse; $self->sort; # Force evaluation

   my $clone = { %{ $self }, %{ $params // {} } };
   my $perms = delete $clone->{_perms}; $clone->{perms} //= $perms;

   return $clone;
};

my $_constructor = sub {
   my $self = shift; return (blessed $self)->new( @_ );
};

my $_inline_args = sub {
   my $n = shift; return (map { $ARG_NAMES[ $_ ] => $_[ $_ ] } 0 .. $n - 1);
};

my $_is_one_of_us = sub {
   return (blessed $_[ 0 ]) && $_[ 0 ]->isa( __PACKAGE__ );
};

sub BUILDARGS { # Differentiate constructor method signatures
   my $class = shift; my $n = 0; $n++ while (defined $_[ $n ]);

   return                 ( $n == 0 ) ? { io_handle => IO::Handle->new }
        : $_is_one_of_us->( $_[ 0 ] ) ? $_clone_one_of_us->( @_ )
        :       is_hashref( $_[ 0 ] ) ? { %{ $_[ 0 ] } }
        :                 ( $n == 1 ) ? { $_inline_args->( 1, @_ ) }
        :       is_hashref( $_[ 1 ] ) ? { name => $_[ 0 ], %{ $_[ 1 ] } }
        :                 ( $n == 2 ) ? { $_inline_args->( 2, @_ ) }
        :                 ( $n == 3 ) ? { $_inline_args->( 3, @_ ) }
                                      : { @_ };
}

sub BUILD {
   my $self = shift; my $handle = $self->io_handle;

   not $self->name and $handle and $self->_set_is_open( $handle->opened );

   return;
}

sub clone {
   my ($self, @args) = @_; blessed $self or throw 'Clone is an object method';

   return $self->$_constructor( $self, @args );
}

sub DEMOLISH {
   my ($self, $gd) = @_;

   $gd and return; # uncoverable branch true
   $self->_atomic ? $self->delete : $self->close;
   return;
}

sub import {
   my ($class, @wanted) = @_; my $package = caller;

   (not defined $wanted[ 0 ] or $wanted[ 0 ] eq 'io')
      and install_sub { into => $package, as => 'io', code => sub (;@) {
         return $class->new( @_ );
      } };

   return;
}

# Private functions
my $_should_include_path = sub {
   return (not defined $_[ 0 ] or (map { $_[ 0 ]->() } ($_[ 1 ]))[ 0 ]);
};

# Private methods
my $_all_file_contents = sub {
   my $self = shift; $self->is_open or $self->assert_open;

   local $RS = undef; my $content = $self->io_handle->getline;

   $self->error_check; $self->autoclose and $self->close;

   return $content;
};

my $_find; $_find = sub {
   my ($self, $files, $dirs, $level) = @_; my (@all, $io);

   my $filter = $self->_filter; my $follow = not $self->_no_follow;

   defined $level or $level = $self->_deep ? 0 : 1;

   while ($io = $self->next) {
      my $is_dir = $io->is_dir; defined $is_dir or next;

      (($files and not $is_dir) or ($dirs and $is_dir))
         and $_should_include_path->( $filter, $io ) and push @all, $io;

      $is_dir and ($follow or not $io->is_link) and $level != 1
         and push @all, $io->$_find( $files, $dirs, $level ? $level - 1 : 0 );
   }

   not $self->sort and return @all;

   return $self->reverse ? sort { $b->name cmp $a->name } @all
                         : sort { $a->name cmp $b->name } @all;
};

my $_get_atomic_path = sub {
   my $self = shift; my $path = $self->filepath; my $file;

   my $infix = $self->_atomic_infix; my $tid = thread_id;

   $infix =~ m{ \%P }mx and $infix =~ s{ \%P }{$PID}gmx;
   $infix =~ m{ \%T }mx and $infix =~ s{ \%T }{$tid}gmx;

   if ($infix =~ m{ \* }mx) {
      my $name = $self->filename; ($file = $infix) =~ s{ \* }{$name}mx;
   }
   else { $file = $self->filename.$infix }

   return $path ? $_catfile->( $path, $file ) : $file;
};

my $_init = sub {
   my ($self, $type, $name) = @_;

   $self->_set_io_handle( undef );
   $self->_set_is_open  ( FALSE );
   $self->_set_name     ( $name ) if ($name);
   $self->_set_mode     ( 'r'   );
   $self->_set_type     ( $type );

   return $self;
};

my $_mkdir_perms = sub { # Take file perms and add execute if read is true
   my $perms = $_[ 1 ] || $_[ 0 ]->_perms;

   return (($perms & oct '0444') >> 2) | $perms;
};

my $_push_layer = sub {
   my ($self, $layer) = @_; $layer //= NUL;

   is_member $layer, $self->_layers and return FALSE;
   push @{ $self->_layers }, $layer;
   return TRUE;
};

my $_sane_binmode = sub {
   my ($self, $layer) = @_;

   blessed $self->io_handle eq 'File::ReadBackwards' and return;

   return $layer ? CORE::binmode( $self->io_handle, $layer )
                 : CORE::binmode( $self->io_handle );
};

my $_throw = sub {
   my $self = shift; eval { $self->unlock }; throw @_;
};

my $_umask_pop = sub {
   my $self = shift; my $perms = $self->_umask->[ -1 ];

   (defined $perms and $perms != NO_UMASK_STACK) or return umask;

   umask pop @{ $self->_umask };
   return $perms;
};

my $_umask_push = sub {
   my ($self, $perms) = @_; $perms or return umask;

   my $first = $self->_umask->[ 0 ];

   defined $first and $first == NO_UMASK_STACK and return umask;

   $perms ^= oct '0777'; push @{ $self->_umask }, umask $perms;

   return $perms;
};

my $_untainted_perms = sub {
   my $self  = shift; $self->exists or return;
   my $stat  = $self->stat   // {};
   my $mode  = $stat->{mode} // NUL;
   my $perms = $mode =~ m{ \A (\d+) \z }mx ? $1 : 0;

   return $perms & oct '07777';
};

my $_assert_open_backwards = sub {
   my ($self, @args) = @_; $self->is_open and return;

   ensure_class_loaded 'File::ReadBackwards';

   $self->_set_io_handle( File::ReadBackwards->new( $self->name, @args ) )
      or $self->$_throw( 'File [_1] cannot open backwards: [_2]',
                         [ $self->name, $OS_ERROR ] );
   $self->_set_is_open( TRUE );
   $self->_set_mode( 'r' );
   $self->set_lock;
   $self->set_binmode;
   return;
};

my $_init_type_from_fs = sub {
   my $self = shift;

   CORE::length $self->name or $self->$_throw( Unspecified, [ 'path name' ] );

   return -f $self->name ? $self->file : -d _ ? $self->dir : undef;
};

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

   CORE::length $self->name or $self->$_throw( Unspecified, [ 'path name' ] );

   my $pathname = $self->_atomic && !$self->is_reading( $mode )
                ? $self->$_get_atomic_path : $self->name;

   $perms = $self->$_untainted_perms || $perms || $self->_perms;

   return ($pathname, $self->_set_mode( $mode ), $self->_set__perms( $perms ));
};

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

   $self->_assert and $self->assert_dirpath( $path );
   $self->_set_io_handle( IO::Dir->new( $path ) )
      or $self->$_throw( 'Directory [_1] cannot open', [ $path ] );
   $self->_set_is_open( TRUE );
   return $self;
};

my $_open_file = sub {
   my ($self, $path, $mode, $perms) = @_;

   $self->_assert and $self->assert_filepath; $self->$_umask_push( $perms );

   unless ($self->_set_io_handle( IO::File->new( $path, $mode ) )) {
      $self->$_umask_pop;
      $self->$_throw( 'File [_1] cannot open', [ $path ] );
   }

   $self->$_umask_pop;
   # TODO: Not necessary on normal systems
   $self->is_writing and CORE::chmod $perms, $path;
   $self->_set_is_open( TRUE );
   $self->set_lock;
   $self->set_binmode;
   return $self;
};

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

   for (@args) {
      print {$self->io_handle} $_
         or $self->$_throw( 'IO error: [_1]', [ $OS_ERROR ] );
   }

   return $self;
};

my $_rename_atomic = sub {
   my $self = shift; my $path = $self->$_get_atomic_path; -f $path or return;

   File::Copy::move( $path, $self->name ) and return;

   is_ntfs or $self->$_throw( 'Path [_1] move to [_2] failed: [_3]',
                              [ $path, $self->name, $OS_ERROR ] );

   # Try this instead on ntfs
   warn 'NTFS: Path '.$self->name." move failure: ${OS_ERROR}\n";
   eval { unlink $self->name }; my $os_error;
   File::Copy::copy( $path, $self->name ) or $os_error = $OS_ERROR;
   eval { unlink $path };
   $os_error and $self->$_throw( 'Path [_1] copy to [_2] failed: [_3]',
                                [ $path, $self->name, $os_error ] );
   return;
};

my $_close_and_rename = sub { # This creates a race condition
   # uncoverable subroutine
   my $self = shift; # uncoverable statement

   my $handle; $self->unlock;

   if ($handle = $self->io_handle) { $handle->close; delete $self->{io_handle} }

   $self->_atomic and $self->$_rename_atomic;

   return $self;
};

my $_getline_backwards = sub {
   my ($self, @args) = @_; $self->$_assert_open_backwards( @args );

   return $self->io_handle->readline;
};

my $_println = sub {
   return shift->$_print( map { m{ [\n] \z }mx ? ($_) : ($_, "\n") } @_ );
};

my $_rename_and_close = sub { # This does not create a race condition
   my $self = shift; my $handle;

   $self->_atomic and $self->$_rename_atomic; $self->unlock;

   if ($handle = $self->io_handle) { $handle->close; delete $self->{io_handle} }

   return $self;
};

my $_getlines_backwards = sub {
   my $self = shift; my (@lines, $line);

   while (defined ($line = $self->$_getline_backwards)) { push @lines, $line }

   return @lines;
};

# Public methods
sub abs2rel {
   return File::Spec->abs2rel( $_[ 0 ]->name, $_[ 1 ] );
}

sub absolute {
   my ($self, $base) = @_; $base and $base = $_coerce_name->( $base );

   $self->_set_name
      ( (CORE::length $self->name) ? $self->rel2abs( $base ) : $base );
   return $self;
}

sub all {
   my ($self, $level) = @_;

   $self->is_dir and return $self->$_find( TRUE, TRUE, $level );

   return $self->$_all_file_contents;
}

sub all_dirs {
   return $_[ 0 ]->$_find( FALSE, TRUE, $_[ 1 ] );
}

sub all_files {
   return $_[ 0 ]->$_find( TRUE, FALSE, $_[ 1 ] );
}

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

   if ($self->is_open and not $self->is_reading) { $self->seek( 0, SEEK_END ) }
   else { $self->assert_open( 'a' ) }

   return $self->$_print( @args );
}

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

   if ($self->is_open and not $self->is_reading) { $self->seek( 0, SEEK_END ) }
   else { $self->assert_open( 'a' ) }

   return $self->$_println( @args );
}

sub as_boolean {
   return ((CORE::length $_[ 0 ]->name) || $_[ 0 ]->io_handle) ? TRUE : FALSE;
}

sub as_string {
   my $self = shift; CORE::length $self->name and return $self->name;

   return defined $self->io_handle ? $self->io_handle.NUL : NUL;
}

sub assert {
   my ($self, $cb) = @_;

   if ($cb) {
      local $_ = $self;
      $cb->() or throw 'Path [_1] assertion failure', [ $self->name ];
   }
   else { $self->_assert( TRUE ) }

   return $self;
}

sub assert_dirpath {
   my ($self, $dir_name) = @_;

   $dir_name or return; -d $dir_name and return $dir_name;

   my $perms = $self->$_mkdir_perms; $self->$_umask_push( oct '07777' );

   unless (CORE::mkdir( $dir_name, $perms )) {
      ensure_class_loaded 'File::Path';
      File::Path::make_path( $dir_name, { mode => $perms } );
   }

   $self->$_umask_pop;

   # uncoverable branch true
   -d $dir_name or $self->$_throw( 'Path [_1] cannot create: [_2]',
                                  [ $dir_name, $OS_ERROR ] );
   return $dir_name;
}

sub assert_filepath {
   my $self = shift; my $dir;

   CORE::length $self->name or $self->$_throw( Unspecified, [ 'path name' ] );

   (undef, $dir) = File::Spec->splitpath( $self->name );

   $self->assert_dirpath( $dir );
   return $self;
}

sub assert_open {
   return $_[ 0 ]->open( $_[ 1 ] // 'r', $_[ 2 ] );
}

sub atomic {
   $_[ 0 ]->_atomic( TRUE ); return $_[ 0 ];
}

sub atomic_infix {
   defined $_[ 1 ] and $_[ 0 ]->_atomic_infix( $_[ 1 ] ); return $_[ 0 ];
}

sub atomic_suffix {
   defined $_[ 1 ] and $_[ 0 ]->_atomic_infix( $_[ 1 ] ); return $_[ 0 ];
}

sub backwards {
   $_[ 0 ]->_backwards( TRUE ); return $_[ 0 ];
}

sub basename {
   my ($self, @suffixes) = @_; CORE::length $self->name or return;

   return File::Basename::basename( $self->name, @suffixes );
}

sub binary {
   my $self = shift;

   $self->$_push_layer( ':raw' ) and $self->is_open and $self->$_sane_binmode;

   return $self;
}

sub binmode {
   my ($self, $layer) = @_;

   $self->$_push_layer( $layer )
      and $self->is_open and $self->$_sane_binmode( $layer );

   return $self;
}

sub block_size {
   defined $_[ 1 ] and $_[ 0 ]->_block_size( $_[ 1 ] ); return $_[ 0 ];
}

sub buffer {
   my $self = shift;

   if (@_) {
      my $buffer_ref  = ref $_[ 0 ] ? $_[ 0 ] : \$_[ 0 ];

      defined ${ $buffer_ref } or ${ $buffer_ref } = NUL;
      $self->{buffer} = $buffer_ref;
      return $self;
   }

   exists $self->{buffer} or $self->{buffer} = do { my $x = NUL; \$x };

   return $self->{buffer};
}

sub canonpath {
   return File::Spec->canonpath( $_[ 0 ]->name );
}

sub catdir {
   my ($self, @args) = @_; return $self->child( @args )->dir;
}

sub catfile {
   my ($self, @args) = @_; return $self->child( @args )->file;
}

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

   my $params = (is_hashref $args[ -1 ]) ? pop @args : {};
   my $args   = [ grep { defined and CORE::length } $self->name, @args ];

   return $self->$_constructor( $args, $params );
}

sub chmod {
   my ($self, $perms) = @_;

   $perms //= $self->_perms; # uncoverable condition false
   CORE::chmod $perms, $self->name;
   return $self;
}

sub chomp {
   $_[ 0 ]->_chomp( TRUE ); return $_[ 0 ];
}

sub chown {
   my ($self, $uid, $gid) = @_;

   (defined $uid and defined $gid)
      or $self->$_throw( Unspecified, [ 'user or group id' ] );

   1 == CORE::chown $uid, $gid, $self->name
      or $self->$_throw( 'Path [_1 chown failed to [_2]/[_3]',
                        [ $self->name, $uid, $gid ] );
   return $self;
}

sub clear {
   ${ $_[ 0 ]->buffer } = NUL; return $_[ 0 ];
}

sub close {
   my $self = shift; $self->is_open or return $self;

   if (is_ntfs) { # uncoverable branch true
      $self->$_close_and_rename; # uncoverable statement
   } else { $self->$_rename_and_close }

   $self->_set_io_handle( undef );
   $self->_set_is_open  ( FALSE );
   $self->_set_mode     ( 'r'   );
   return $self;
}

sub copy {
   my ($self, $to) = @_;

   $to or $self->$_throw( Unspecified, [ 'copy to' ] );

   (blessed $to and $to->isa( __PACKAGE__ ))
      or $to = $self->$_constructor( $to );

   File::Copy::copy( $self->name, $to->pathname )
      or $self->$_throw( 'Cannot copy [_1] to [_2]',
                         [ $self->name, $to->pathname ] );

   return $to;
}

sub cwd {
   my $self = shift; return $self->$_constructor( Cwd::getcwd(), @_ );
}

sub deep {
   $_[ 0 ]->_deep( TRUE ); return $_[ 0 ];
}

sub delete {
   my $self = shift; my $path = $self->$_get_atomic_path;

   $self->_atomic and -f $path and unlink $path;

   return $self->close;
}

sub delete_tmp_files {
   my ($self, $tmplt) = @_; $tmplt //= '%6.6d....';

   my $pat = sprintf $tmplt, $PID;

   while (my $entry = $self->next) {
      $entry->filename =~ m{ \A $pat \z }mx and unlink $entry->pathname;
   }

   return $self->close;
}

sub digest { # Robbed from Path::Tiny
   my ($self, @args) = @_; my $n = 0; $n++ while (defined $args[ $n ]);

   my $args = (              $n == 0) ? { algorithm => 'SHA-256'  }
            : (is_hashref $args[ 0 ]) ? { algorithm => 'SHA-256',
                                          %{ $args[ 0 ] } }
            : (              $n == 1) ? { algorithm => $args[ 0 ] }
                                      : { algorithm => $args[ 0 ],
                                          %{ $args[ 1 ] } };

   ensure_class_loaded 'Digest'; my $digest = Digest->new( $args->{algorithm} );

   if ($args->{block_size}) {
      $self->binmode( ':unix' )->lock->block_size( $args->{block_size} );

      while ($self->read) { $digest->add( ${ $self->buffer } ); $self->clear; }
   }
   else { $digest->add( $self->binmode( ':unix' )->lock->all ) }

   return $digest;
}

sub dir {
   return shift->$_init( 'dir', @_ );
}

sub dirname {
   return CORE::length $_[ 0 ]->name ? File::Basename::dirname( $_[ 0 ]->name )
                                     : NUL;
}

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

   $encoding or $self->$_throw( Unspecified, [ 'encoding value' ] );
   $self->$_push_layer( ":encoding($encoding)" )
      and $self->is_open and $self->$_sane_binmode( ":encoding($encoding)" );
   return $self;
}

sub error_check {
   my $self = shift;

   $self->io_handle->can( 'error' )
      and $self->io_handle->error
      and $self->$_throw( 'IO error: [_1]', [ $OS_ERROR ] );

   return $self;
}

sub exists {
   return (CORE::length $_[ 0 ]->name && -e $_[ 0 ]->name) ? TRUE : FALSE;
}

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

   $self->io_handle->fdopen( $fd, $mode );
   $self->_set_is_open( $self->io_handle->opened );
   $self->_set_mode( $mode );
   $self->_set_name( NUL   );
   $self->_set_type( undef );
   return $self;
}

sub file {
   return shift->$_init( 'file', @_ );
}

sub filename {
   my $self = shift; my $file;

   (undef, undef, $file) = File::Spec->splitpath( $self->name );

   return $file;
}

sub filepath {
   my $self = shift; my ($volume, $dir) = File::Spec->splitpath( $self->name );

   return File::Spec->catpath( $volume, $dir, NUL );
}

sub filter {
   defined $_[ 1 ] and $_[ 0 ]->_filter( $_[ 1 ] ); return $_[ 0 ];
}

sub getline {
   my ($self, $separator) = @_;

   $self->_backwards and return $self->$_getline_backwards;

   my $line; $self->assert_open;

   {  local $RS = $separator // $self->_separator; # uncoverable condition false
      $line = $self->io_handle->getline;
      defined $line and $self->_chomp and CORE::chomp $line;
   }

   $self->error_check;
   defined $line and return $line;
   $self->autoclose and $self->close;
   return;
}

sub getlines {
   my ($self, $separator) = @_;

   $self->_backwards and return $self->$_getlines_backwards;

   my @lines; $self->assert_open;

   {  local $RS = $separator // $self->_separator; # uncoverable condition false
      @lines = $self->io_handle->getlines;

      if ($self->_chomp) { CORE::chomp for @lines }
   }

   $self->error_check;
   scalar @lines and return (@lines);
   $self->autoclose and $self->close;
   return ();
}

sub head {
   my ($self, $lines) = @_; my @res; $lines //= 10; $self->close;

   while ($lines--) {
      defined (my $l = $self->getline) or last; push @res, $l;
   }

   $self->close;
   return wantarray ? @res : join NUL, @res;
}

sub hexdigest {
   my ($self, @args) = @_; return $self->digest( @args )->hexdigest;
}

sub is_absolute {
   return File::Spec->file_name_is_absolute( $_[ 0 ]->name );
}

sub is_dir {
   my $self = shift; CORE::length $self->name or return FALSE;

   $self->type or $self->$_init_type_from_fs or return FALSE;

   return $self->type eq 'dir' ? TRUE : FALSE;
}

sub is_empty {
   my $self = shift; my $name = $self->name; my $empty;

   $self->exists  or  $self->$_throw( PathNotFound, [ $name ] );
   $self->is_file and return -z $name ? TRUE : FALSE;
   $empty = $self->next ? FALSE : TRUE; $self->close;
   return $empty;
}

*empty = \&is_empty; # Deprecated

sub is_executable {
   return (CORE::length $_[ 0 ]->name) && -x $_[ 0 ]->name ? TRUE : FALSE;
}

sub is_file {
   my $self = shift; CORE::length $self->name or return FALSE;

   $self->type or $self->$_init_type_from_fs or return FALSE;

   return $self->type eq 'file' ? TRUE : FALSE;
}

sub is_link {
   return (CORE::length $_[ 0 ]->name) && -l $_[ 0 ]->name ? TRUE : FALSE;
}

sub is_readable {
   return (CORE::length $_[ 0 ]->name) && -r $_[ 0 ]->name ? TRUE : FALSE;
}

sub is_reading {
   my $mode = $_[ 1 ] // $_[ 0 ]->mode; return first { $_ eq $mode } qw( r r+ );
}

sub is_writable {
   return (CORE::length $_[ 0 ]->name) && -w $_[ 0 ]->name ? TRUE : FALSE;
}

sub is_writing {
   my $mode = $_[ 1 ] // $_[ 0 ]->mode;

   return first { $_ eq $mode } qw( a a+ w w+ );
}

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

   $self->is_dir
      or $self->$_throw( "Path [_1] is not a directory", [ $self->name ] );

   my @dirs   = ( $self );
   my $filter = $self->_filter;
   my $deep   = $args->{recurse} // $self->_deep;
   my $follow = $args->{follow_symlinks} // not $self->_no_follow;

   return sub {
      while (@dirs) {
         while (defined (my $path = $dirs[ 0 ]->next)) {
            $deep and $path->is_dir and ($follow or not $path->is_link)
               and unshift @dirs, $path;
            $_should_include_path->( $filter, $path ) and return $path;
         }

         shift @dirs;
      }

      return;
   };
}

sub length {
   return CORE::length ${ $_[ 0 ]->buffer };
}

sub lock {
   $_[ 0 ]->_lock( $_[ 1 ] // LOCK_BLOCKING ); return $_[ 0 ];
}

sub mkdir {
   my ($self, $perms) = @_; $perms ||= $self->$_mkdir_perms;

   $self->$_umask_push( oct '07777' );

   CORE::mkdir( $self->name, $perms );

   $self->$_umask_pop;

   -d $self->name or $self->$_throw( 'Path [_1] cannot create: [_2]',
                                     [ $self->name, $OS_ERROR ] );
   return $self;
}

sub mkpath {
   my ($self, $perms) = @_; $perms ||= $self->$_mkdir_perms;

   $self->$_umask_push( oct '07777' ); ensure_class_loaded 'File::Path';

   File::Path::make_path( $self->name, { mode => $perms } );

   $self->$_umask_pop;

   -d $self->name or $self->$_throw( 'Path [_1] cannot create: [_2]',
                                     [ $self->name, $OS_ERROR ] );
   return $self;
}

sub move {
   my ($self, $to) = @_;

   $to or $self->$_throw( Unspecified, [ 'move to' ] );

   (blessed $to and $to->isa( __PACKAGE__ ))
      or $to = $self->$_constructor( $to );

   File::Copy::move( $self->name, $to->pathname )
      or $self->$_throw( 'Cannot move [_1] to [_2]',
                         [ $self->name, $to->pathname ] );

   return $to;
}

sub next {
   my $self = shift; defined (my $name = $self->read_dir) or return;

   my $io = $self->$_constructor( [ $self->name, $name ], {
      reverse => $self->reverse, sort => $self->sort } );

   defined $self->_filter and $io->filter( $self->_filter );

   return $io;
}

sub no_follow {
   $_[ 0 ]->_no_follow( TRUE ); return $_[ 0 ];
}

sub open {
   my ($self, $mode, $perms) = @_; $mode //= $self->mode;

   $self->is_open
      and first_char $mode eq first_char $self->mode
      and return $self;
   $self->is_open
      and 'r' eq first_char $mode
      and '+' eq (substr $self->mode, 1, 1) || NUL
      and $self->seek( 0, SEEK_SET )
      and return $self;
   $self->type or $self->$_init_type_from_fs; $self->type or $self->file;
   $self->is_open and $self->close;

   return $self->is_dir
        ? $self->$_open_dir ( $self->$_open_args( $mode, $perms ) )
        : $self->$_open_file( $self->$_open_args( $mode, $perms ) );
}

sub parent {
   my ($self, $count) = @_; my $parent = $self; $count ||= 1;

   $parent = $self->$_constructor( $parent->dirname ) while ($count--);

   return $parent;
}

sub pathname {
   return $_[ 0 ]->name;
}

sub perms {
   defined $_[ 1 ] and $_[ 0 ]->_set__perms( $_[ 1 ] ); return $_[ 0 ];
}

sub print {
   return shift->assert_open( 'w' )->$_print( @_ );
}

sub println {
   return shift->assert_open( 'w' )->$_println( @_ );
}

sub read {
   my ($self, @args) = @_; $self->assert_open;

   my $length = @args || $self->is_dir
              ? $self->io_handle->read( @args )
              : $self->io_handle->read( ${ $self->buffer },
                                        $self->_block_size, $self->length );

   $self->error_check;

   return $length || $self->autoclose && $self->close && 0;
}

sub read_dir {
   my $self = shift; $self->type or $self->dir; $self->assert_open;

   $self->is_link and $self->_no_follow and $self->close and return;

   my $dir_pat = $self->_dir_pattern; my $name;

   if (wantarray) {
      my @names = grep { $_ !~ $dir_pat } $self->io_handle->read;

      $self->close; return @names;
   }

   while (not defined $name or $name =~ $dir_pat) {
      unless (defined ($name = $self->io_handle->read)) {
         $self->close; return;
      }
   }

   return $name;
}

sub rel2abs {
   my ($self, $base) = @_;

   return File::Spec->rel2abs( $self->name, defined $base ? "${base}" : undef );
}

sub relative {
   $_[ 0 ]->_set_name( $_[ 0 ]->abs2rel ); return $_[ 0 ];
}

sub reset {
   my $self = shift; $self->close;

   $self->_assert( FALSE ); $self->_atomic( FALSE ); $self->_chomp    ( FALSE );
   $self->_deep  ( FALSE ); $self->_lock  ( FALSE ); $self->_no_follow( FALSE );
   return $self;
}

sub rmdir {
   my $self = shift;

   CORE::rmdir $self->name
      or $self->$_throw( 'Path [_1] not removed: [_2]',
                         [ $self->name, $OS_ERROR ] );
   return $self;
}

sub rmtree {
   my ($self, @args) = @_; ensure_class_loaded 'File::Path';

   return File::Path::remove_tree( $self->name, @args );
}

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

   $self->is_open or $self->assert_open( is_mswin ? 'r' : 'r+' );
   CORE::seek $self->io_handle, $posn, $whence; $self->error_check;
   return $self;
}

sub separator {
   defined $_[ 1 ] and $_[ 0 ]->_separator( $_[ 1 ] ); return $_[ 0 ];
}

sub set_binmode {
   my $self = shift;

   is_ntfs and $self->$_push_layer(); # uncoverable branch true

   $self->$_sane_binmode( $_ ) for (@{ $self->_layers });

   return $self;
}

sub set_lock {
   my $self = shift; $self->_lock or return;

   my $async = $self->_lock == LOCK_NONBLOCKING ? TRUE : FALSE;
   my $mode  = $self->mode eq 'r' ? LOCK_SH : LOCK_EX;

   $async and $mode |= LOCK_NB;
   $self->_set_have_lock( (flock $self->io_handle, $mode) ? TRUE : FALSE );
   return $self;
}

sub sibling {
   my $self = shift; return $self->parent->child( @_ );
}

sub slurp {
   my $self = shift; my $slurp = $self->all;

   wantarray or return $slurp; local $RS = $self->_separator;

   $self->_chomp or return split m{ (?<=\Q$RS\E) }mx, $slurp;

   return map { CORE::chomp; $_ } split m{ (?<=\Q$RS\E) }mx, $slurp;
}

sub splitdir {
   return File::Spec->splitdir( $_[ 0 ]->name );
}

sub splitpath {
   return File::Spec->splitpath( $_[ 0 ]->name );
}

sub stat {
   my $self = shift; $self->exists or $self->is_open or return;

   my %stat_hash = ( id => $self->filename );

   @stat_hash{ STAT_FIELDS() }
      = stat( $self->exists ? $self->name : $self->io_handle );

   return \%stat_hash;
}

sub substitute {
   my ($self, $search, $replace) = @_; $replace //= NUL;

   (defined $search and CORE::length $search) or return $self;

   my $perms = $self->$_untainted_perms;
   my $wtr   = $self->$_constructor( $self->name )->atomic;

   $perms and $wtr->perms( $perms );

   for ($self->getlines) { s{ $search }{$replace}gmx; $wtr->print( $_ ) }

   $self->close; $wtr->close;
   return $self;
}

sub tail {
   my ($self, $lines, @args) = @_; my @res; $lines //= 10; $self->close;

   while ($lines--) {
      unshift @res, ($self->$_getline_backwards( @args ) or last);
   }

   $self->close;
   return wantarray ? @res : join NUL, @res;
}

sub tell {
   my $self = shift;

   $self->is_open or $self->assert_open( is_mswin ? 'r' : 'r+' );

   return CORE::tell $self->io_handle;
}

sub tempfile {
   my ($self, $tmplt) = @_; my $tempdir;

   ensure_class_loaded 'File::Temp'; $tmplt ||= '%6.6dXXXX';

   ($tempdir = $self->name and -d $tempdir) or $tempdir = File::Spec->tmpdir;

   my $tmpfh = File::Temp->new
      ( DIR => $tempdir, TEMPLATE => (sprintf $tmplt, $PID) );
   my $t     = $self->$_constructor( $tmpfh->filename )->file;

   $t->_set_io_handle( $tmpfh ); $t->_set_is_open( TRUE );
   $t->_set_mode( 'w+' );
   return $t;
}

sub touch {
   my ($self, $time) = @_; CORE::length $self->name or return; $time //= time;

   -e $self->name or $self->$_open_file( $self->$_open_args( 'w' ) )->close;

   utime $time, $time, $self->name;
   return $self;
}

sub unlink {
   return unlink $_[ 0 ]->name;
}

sub unlock {
   my $self = shift; $self->_lock or return; my $handle = $self->io_handle;

   $handle and $handle->opened and flock $handle, LOCK_UN;
   $self->_set_have_lock( FALSE );
   return $self;
}

sub utf8 {
   $_[ 0 ]->encoding( 'UTF-8' ); return $_[ 0 ];
}

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

   my $iter = $self->iterator( $args ); my $state = {};

   while (defined (my $entry = $iter->())) {
      local $_ = $entry; my $r = $cb->( $entry, $state );

      ref $r and not ${ $r } and last;
   }

   return $state;
}

sub write {
   my ($self, @args) = @_; $self->assert_open( 'w' );

   my $length = @args
              ? $self->io_handle->write( @args )
              : $self->io_handle->write( ${ $self->buffer }, $self->length );

   $self->error_check; scalar @args or $self->clear;
   return $length;
}

# Method installer
my $_proxy = sub { # Methods handled by the IO::Handle object
   my ($proxy, $chain, $mode) = @_;

   my $package = caller; $package->can( $proxy ) and return;

   install_sub { into => $package, as => $proxy, code => sub {
      my $self = shift; defined $mode and $self->assert_open( $mode );

      defined $self->io_handle or throw InvocantUndefined, [ $proxy ];

      my @results = $self->io_handle->$proxy( @_ ); # Mustn't copy stack args

      $self->error_check; $chain and return $self;

      return wantarray ? @results : $results[ 0 ];
   } };
};

$_proxy->( 'autoflush', TRUE );
$_proxy->( 'eof'             );
$_proxy->( 'fileno'          );
$_proxy->( 'flush',     TRUE );
$_proxy->( 'getc',      FALSE, 'r' );
$_proxy->( 'sysread',   FALSE, O_RDONLY );
$_proxy->( 'syswrite',  FALSE, O_CREAT | O_WRONLY );
$_proxy->( 'truncate',  TRUE );

1;

__END__