view release on metacpan or  search on metacpan

lib/File/DataClass/IO.pm  view on Meta::CPAN

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;