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


line stmt bran cond sub pod time code
1             package IPC::ConcurrencyLimit::WithStandby;
2 3     3   77052 use 5.008001;
  3         57  
3 3     3   12 use strict;
  3         6  
  3         57  
4 3     3   9 use warnings;
  3         6  
  3         129  
5              
6             our $VERSION = '0.17';
7 3     3   12 use Carp qw(croak);
  3         3  
  3         138  
8 3     3   2250 use Time::HiRes qw(sleep);
  3         4617  
  3         18  
9 3     3   2064 use IPC::ConcurrencyLimit;
  3         6  
  3         2721  
10              
11             sub new {
12 8     8 0 106682 my $class = shift;
13 8         93 my %params = @_;
14 8         26 my $type = delete $params{type};
15 8 50       61 $type = 'Flock' if not defined $type;
16              
17 8   33     65 my $standby_type = delete($params{standby_type}) || $type;
18              
19 8         31 foreach my $t ($type, $standby_type) {
20 16         39 my $lock_class = "IPC::ConcurrencyLimit::Lock::$t";
21 16 50       1628 if (not eval "require $lock_class; 1;") {
22 0   0     0 my $err = $@ || 'Zombie error';
23 0         0 croak("Invalid lock type '$t'. Could not load lock class '$lock_class': $err");
24             }
25             }
26              
27 8         13 my %standby;
28 8         94 foreach my $key (grep /^standby_/, keys %params) {
29 10         16 my $munged = $key;
30 10         37 $munged =~ s/^standby_//;
31 10         36 $standby{$munged} = delete $params{$key};
32             }
33 8         60 $standby{$_} = $params{$_} for grep !exists($standby{$_}), keys %params;
34              
35 8         76 my $main_lock = IPC::ConcurrencyLimit->new(%params, type => $type);
36 8         36 my $standby_lock = IPC::ConcurrencyLimit->new(%standby, type => $standby_type);
37              
38             my $self = bless({
39             main_lock => $main_lock,
40             standby_lock => $standby_lock,
41             retries => defined($params{retries}) ? $params{retries} : 10,
42             interval => defined($params{interval}) ? $params{interval} : 1,
43             process_name_change => $params{process_name_change},
44 8 50       101 } => $class);
    50          
45              
46 8         39 return $self;
47             }
48              
49             sub get_lock {
50 10     10 0 2533 my $self = shift;
51 10         38 my $main_lock = $self->{main_lock};
52              
53             # Convert retries to a sub if it's not one already
54 10 100       47 if ( ref $self->{retries} ne "CODE" ) {
55 6         6 my $max_retries = $self->{retries};
56 6     41   27 $self->{retries} = sub { return $_[0] <= $max_retries };
  41         119  
57             }
58              
59 10         52 my $id = $main_lock->get_lock;
60 10 100       43 return $id if defined $id;
61              
62 6         20 my $st_lock = $self->{standby_lock};
63 6         26 my $st_id = $st_lock->get_lock;
64 6 50       20 return undef if not defined $st_id;
65              
66             # got standby lock, go into wait-retry loop
67 6         7 my $old_proc_name;
68 6 50       50 if ($self->{process_name_change}) {
69 0         0 $old_proc_name = $0;
70 0         0 $0 = "$0 - standby";
71             }
72 6         8 my $interval = $self->{interval};
73             eval {
74 6         20 my $tries = 0;
75 6         10 while (1) {
76 324         3142 $id = $main_lock->get_lock;
77 324 100       923 if (defined $id) {
78 3         189 $st_lock->release_lock;
79 3         3 last;
80             }
81              
82 321 100       1695 last unless $self->{retries}->(++$tries);
83 318 100       6833839 sleep($interval) if $interval;
84             }
85 6         27 1;
86             }
87 6 50       30 or do {
88 0   0     0 my $err = $@ || 'Zombie error';
89 0 0       0 $0 = $old_proc_name if defined $old_proc_name;
90 0         0 $st_lock->release_lock;
91 0         0 die $err;
92             };
93              
94 6 50       17 $0 = $old_proc_name if defined $old_proc_name;
95 6         27 return $id;
96             }
97              
98             sub is_locked {
99 0     0 0 0 my $self = shift;
100 0         0 return $self->{main_lock}->is_locked(@_);
101             }
102              
103             sub release_lock {
104 4     4 0 5004377 my $self = shift;
105 4         98 return $self->{main_lock}->release_lock(@_);
106             }
107              
108             sub lock_id {
109 0     0 0   my $self = shift;
110 0           return $self->{main_lock}->lock_id(@_);
111             }
112              
113             sub heartbeat {
114 0     0 0   my $self = shift;
115 0           return $self->{main_lock}->heartbeat;
116             }
117              
118             1;
119              
120             __END__