File Coverage

blib/lib/IPC/ConcurrencyLimit/Lock/Flock.pm

Criterion	Covered	Total	%
statement	61	64	95.3
branch	19	24	79.1
condition	2	2	100.0
subroutine	12	14	85.7
pod	3	3	100.0
total	97	107	90.6

package IPC::ConcurrencyLimit::Lock::Flock;
use 5.008001;
use strict;
use warnings;
use Carp qw(croak);
use File::Path qw();
use File::Spec;
use Fcntl qw(:DEFAULT :flock);
use IO::File ();

our $VERSION = '0.17';
use IPC::ConcurrencyLimit::Lock;
our @ISA = qw(IPC::ConcurrencyLimit::Lock);

sub new {
  my $class = shift;
  my $opt = shift;

  my $max_procs = $opt->{max_procs}
    or croak("Need a 'max_procs' parameter");
  my $path = $opt->{path}
    or croak("Need a 'path' parameter");
  my $lock_mode = lc($opt->{lock_mode} || 'exclusive');
  if ($lock_mode !~ /^(?:exclusive|shared)$/) {
    croak("Invalid lock mode '$lock_mode'");
  }
  my $file_prefix= defined $opt->{file_prefix} ? $opt->{file_prefix} : "";
  $file_prefix .= "." if length $file_prefix;
  my $file_ext= defined $opt->{file_ext} ? $opt->{file_ext} : "lock";
  $file_ext=~s/^\.?/./;

  my $self = bless {
    max_procs => $max_procs,
    path      => $path,
    lock_fh   => undef,
    lock_file => undef,
    id        => undef,
    file_prefix => $file_prefix,
    file_ext    => $file_ext,
    lock_mode => $lock_mode,
  } => $class;

  $self->_get_lock() or return undef;

  return $self;
}

sub _get_lock {
  my $self = shift;

  File::Path::mkpath($self->{path});
  my $lock_mode_flag = $self->{lock_mode} eq 'shared' ? LOCK_SH : LOCK_EX;

  # We try in reverse order, so that if a processor is started with
  # a higher number of allowed locks there is less chance that it starves
  # a processor with a lower number of allowed locks.
  my $worker_id = $self->{max_procs};
  while ($worker_id > 0) {
    my $lock_file = File::Spec->catfile($self->{path}, join("", $self->{file_prefix}, $worker_id, $self->{file_ext}));

    sysopen(my $fh, $lock_file, O_RDWR|O_CREAT)
      or die "can't open '$lock_file': $!";

    if (flock($fh, $lock_mode_flag|LOCK_NB)) {
      $self->{lock_fh} = $fh;
      seek($fh, 0, 0);
      truncate($fh, 0);
      print $fh $$;
      $fh->flush;
      $self->{id} = $worker_id;
      $self->{lock_file} = $lock_file;
      last;
    }

    close $fh;
    $worker_id--;
  }

  return undef if not $self->{id};
  return 1;
}

sub lock_file { $_[0]->{lock_file} }
sub path { $_[0]->{path} }

sub DESTROY {
  my $self = shift;
  # should be superfluous
  close($self->{lock_fh}) if $self->{lock_fh};
}

1;

__END__