File Coverage

lib/IPC/SRLock/Fcntl.pm

Criterion	Covered	Total	%
statement	50	50	100.0
branch	2	4	100.0
condition	3	6	83.3
subroutine	14	14	100.0
pod	3	3	100.0
total	72	77	98.7

package IPC::SRLock::Fcntl;

use namespace::autoclean;

use English                    qw( -no_match_vars );
use File::DataClass::Constants qw( LOCK_BLOCKING LOCK_NONBLOCKING );
use File::DataClass::Types     qw( Directory NonEmptySimpleStr
                                   OctalNum Path PositiveInt RegexpRef );
use File::Spec;
use IPC::SRLock::Utils         qw( Unspecified hash_from loop_until
                                   merge_attributes throw );
use Storable                   qw( nfreeze thaw );
use Try::Tiny;
use Moo;

extends q(IPC::SRLock::Base);

# Attribute constructors
my $_build_lockfile = sub {
   my $self = shift; my $path = $self->_lockfile_name;

   # uncoverable condition false
   $path ||= $self->tempdir->catfile( $self->name.'.lck' );
   # uncoverable branch true
   $path  =~ $self->pattern or throw 'Path [_1] cannot untaint', [ $path ];

   return $path;
};

my $_build__shmfile = sub {
   my $self = shift; my $path = $self->_shmfile_name;

   # uncoverable condition false
   $path ||= $self->tempdir->catfile( $self->name.'.shm' );
   # uncoverable branch true
   $path  =~ $self->pattern or throw 'Path [_1] cannot untaint', [ $path ];

   return $path;
};

# Public attributes
has 'lockfile' => is => 'lazy', isa => Path, coerce => 1,
   builder     => $_build_lockfile;

has 'mode'    => is => 'ro', isa => OctalNum, coerce => 1, default => '0666';

has 'pattern' => is => 'ro', isa => RegexpRef,
   default    => sub { qr{ \A ([ ~:+./\-\\\w]+) \z }msx };

has 'tempdir' => is => 'ro', isa => Directory, coerce => 1,
   default    => sub { File::Spec->tmpdir };

has 'umask'   => is => 'ro', isa => PositiveInt, default => 0;

# Private attributes
has '_lockfile_name' => is => 'ro',   isa => NonEmptySimpleStr,
   init_arg          => 'lockfile';

has '_shmfile'       => is => 'lazy', isa => Path, coerce => 1,
   builder           => $_build__shmfile;

has '_shmfile_name'  => is => 'ro',   isa => NonEmptySimpleStr,
   init_arg          => 'shmfile';

# Construction
around 'BUILDARGS' => sub {
   my ($orig, $self, @args) = @_; my $attr = $orig->( $self, @args );

   my $builder = $attr->{builder} or return $attr;
   my $config  = $builder->can( 'config' ) ? $builder->config : {};

   merge_attributes $attr, $config, [ 'tempdir' ];

   return $attr;
};

# Private methods
my $_expire_lock = sub {
   my ($self, $content, $key, $lock) = @_;

   $self->log->error
      ( $self->_timeout_error
        ( $key, $lock->{spid}, $lock->{stime}, $lock->{timeout} ) );

   delete $content->{ $key };
   return 0;
};

my $_read_shmfile = sub {
   my ($self, $async) = @_; my ($file, $content);

   my $old_umask = umask $self->umask;
   my $mode      = $async ? LOCK_NONBLOCKING : LOCK_BLOCKING;
   my $shmfile   = $self->_shmfile;

   try {
      $file = $self->lockfile->lock( $mode )->assert_open( 'w', $self->mode );
   }
   catch { umask $old_umask; throw $_ };

   if ($file->have_lock and $shmfile->exists) {
      try   { $content = thaw $shmfile->all }
      catch { $file->close; umask $old_umask; throw $_ };
   }
   else { $content = {} }

   $shmfile->close; umask $old_umask;
   return ($file, $content);
};

my $_unlock_share = sub {
   $_[ 0 ]->close; return 1;
};

my $_write_shmfile = sub {
   my ($self, $lock_file, $content) = @_; my $wtr;

   try   { $wtr = $self->_shmfile->assert_open( 'w', $self->mode ) }
   catch { $_unlock_share->( $lock_file ); throw $_ };

   try   { $wtr->print( nfreeze $content ) }
   catch { $wtr->delete; $_unlock_share->( $lock_file ); throw $_ };

   $wtr->close; $_unlock_share->( $lock_file );
   return 1;
};

my $_reset = sub {
   my ($self, $args) = @_; my $key = $args->{k}; my $pid = $args->{p};

   my ($lock_file, $shm_content) = $self->$_read_shmfile;

   my $lock; exists $shm_content->{ $key }
      and $lock = $shm_content->{ $key }
      and $lock->{spid} != $pid
      and $_unlock_share->( $lock_file )
      and throw 'Lock [_1] set by another process', [ $key ];

   not delete $shm_content->{ $key } and $_unlock_share->( $lock_file )
      and throw 'Lock [_1] not set', [ $key ];

   return $self->$_write_shmfile( $lock_file, $shm_content );
};

my $_set = sub {
   my ($self, $args, $now) = @_; my $key = $args->{k}; my $pid = $args->{p};

   my ($lock_file, $shm_content) = $self->$_read_shmfile( $args->{async} );

   not $lock_file->have_lock and $_unlock_share->( $lock_file ) and return 0;

   my $lock; exists $shm_content->{ $key }
      and $lock = $shm_content->{ $key }
      and $lock->{timeout}
      and $now > $lock->{stime} + $lock->{timeout}
      and $lock = $self->$_expire_lock( $shm_content, $key, $lock );

   $lock and $_unlock_share->( $lock_file ) and return 0;

   $shm_content->{ $key }
      = { spid => $pid, stime => $now, timeout => $args->{t} };
   $self->$_write_shmfile( $lock_file, $shm_content );
   $self->log->debug( "Lock ${key} set by ${pid}" );
   return 1;
};

# Public methods
sub list {
   my $self = shift; my $list = [];

   my ($lock_file, $shm_content) = $self->$_read_shmfile; $lock_file->close;

   while (my ($key, $info) = each %{ $shm_content }) {
      push @{ $list }, { key     => $key,
                         pid     => $info->{spid},
                         stime   => $info->{stime},
                         timeout => $info->{timeout} };
   }

   return $list;
}

sub reset {
   my $self = shift; return $self->$_reset( $self->_get_args( @_ ) );
}

sub set {
   my ($self, @args) = @_; return loop_until( $_set )->( $self, @args );
}

1;

__END__