File Coverage

blib/lib/IPC/ConcurrencyLimit/WithStandby.pm

Criterion	Covered	Total	%
statement	63	77	81.8
branch	18	28	64.2
condition	1	7	14.2
subroutine	10	13	76.9
pod	0	6	0.0
total	92	131	70.2

package IPC::ConcurrencyLimit::WithStandby;
use 5.008001;
use strict;
use warnings;

our $VERSION = '0.16';
use Carp qw(croak);
use Time::HiRes qw(sleep);
use IPC::ConcurrencyLimit;

sub new {
  my $class = shift;
  my %params = @_;
  my $type = delete $params{type};
  $type = 'Flock' if not defined $type;

  my $standby_type = delete($params{standby_type}) || $type;

  foreach my $t ($type, $standby_type) {
    my $lock_class = "IPC::ConcurrencyLimit::Lock::$t";
    if (not eval "require $lock_class; 1;") {
      my $err = $@ || 'Zombie error';
      croak("Invalid lock type '$t'. Could not load lock class '$lock_class': $err");
    }
  }

  my %standby;
  foreach my $key (grep /^standby_/, keys %params) {
    my $munged = $key;
    $munged =~ s/^standby_//;
    $standby{$munged} = delete $params{$key};
  }
  $standby{$_} = $params{$_} for grep !exists($standby{$_}), keys %params;

  my $main_lock = IPC::ConcurrencyLimit->new(%params, type => $type);
  my $standby_lock = IPC::ConcurrencyLimit->new(%standby, type => $standby_type);

  my $self = bless({
    main_lock => $main_lock,
    standby_lock => $standby_lock,
    retries => defined($params{retries}) ? $params{retries} : 10,
    interval => defined($params{interval}) ? $params{interval} : 1,
    process_name_change => $params{process_name_change},
  } => $class);

  return $self;
}

sub get_lock {
  my $self = shift;
  my $main_lock = $self->{main_lock};

  # Convert retries to a sub if it's not one already
  if ( ref $self->{retries} ne "CODE" ) {
      my $max_retries = $self->{retries};
      $self->{retries} = sub { return $_[0] <= $max_retries };
  }

  my $id = $main_lock->get_lock;
  return $id if defined $id;

  my $st_lock = $self->{standby_lock};
  my $st_id = $st_lock->get_lock;
  return undef if not defined $st_id;

  # got standby lock, go into wait-retry loop
  my $old_proc_name;
  if ($self->{process_name_change}) {
    $old_proc_name = $0;
    $0 = "$0 - standby";
  }
  my $interval = $self->{interval};
  eval {
    my $tries = 0;
    while (1) {
      $id = $main_lock->get_lock;
      if (defined $id) {
        $st_lock->release_lock;
        last;
      }

      last unless $self->{retries}->(++$tries);
      sleep($interval) if $interval;
    }
    1;
  }
  or do {
    my $err = $@ || 'Zombie error';
    $0 = $old_proc_name if defined $old_proc_name;
    $st_lock->release_lock;
    die $err;
  };

  $0 = $old_proc_name if defined $old_proc_name;
  return $id;
}

sub is_locked {
  my $self = shift;
  return $self->{main_lock}->is_locked(@_);
}

sub release_lock {
  my $self = shift;
  return $self->{main_lock}->release_lock(@_);
}

sub lock_id {
  my $self = shift;
  return $self->{main_lock}->lock_id(@_);
}

sub heartbeat {
  my $self = shift;
  return $self->{main_lock}->heartbeat;
}

1;

__END__