File Coverage

blib/lib/IPC/ConcurrencyLimit/Lock/MySQL.pm
Criterion Covered Total %
statement 18 59 30.5
branch 0 22 0.0
condition 0 11 0.0
subroutine 6 11 54.5
pod 1 1 100.0
total 25 104 24.0


line stmt bran cond sub pod time code
1             package IPC::ConcurrencyLimit::Lock::MySQL;
2 2     2   75998 use 5.008001;
  2         9  
  2         84  
3 2     2   13 use strict;
  2         4  
  2         76  
4 2     2   11 use warnings;
  2         7  
  2         95  
5              
6             our $VERSION = '0.03';
7              
8 2     2   11 use Carp qw(croak);
  2         3  
  2         322  
9             use Class::XSAccessor {
10 2         25 accessors => [qw(dbh id timeout)],
11             getters => [qw(make_new_dbh_callback lock_name)],
12 2     2   2019 };
  2         8102  
13              
14 2     2   3787 use IPC::ConcurrencyLimit::Lock;
  2         349  
  2         1303  
15             our @ISA = qw(IPC::ConcurrencyLimit::Lock);
16              
17             sub new {
18 0     0 1   my $class = shift;
19 0           my $opt = shift;
20              
21 0 0         my $max_procs = $opt->{max_procs}
22             or croak("Need a 'max_procs' parameter");
23              
24 0           my $dbh_callback = $opt->{make_new_dbh};
25 0 0 0       $dbh_callback && ref($dbh_callback) eq 'CODE'
26             or croak("Need a 'make_new_dbh' callback as parameter");
27              
28 0           my $lock_name = $opt->{lock_name};
29 0 0         defined $lock_name
30             or croak("Need a 'lock_name' parameter for the lock");
31              
32 0   0       my $self = bless {
33             lock_name => $lock_name,
34             max_procs => $max_procs,
35             make_new_dbh_callback => $dbh_callback,
36             timeout => $opt->{timeout}||0,
37             dbh => undef,
38             id => undef,
39             } => $class;
40              
41 0 0         $self->_get_lock() or return undef;
42              
43 0           return $self;
44             }
45              
46             sub _get_dbh {
47 0     0     my $self = shift;
48 0           my $dbh = $self->dbh;
49              
50 0 0         if (not defined $dbh) {
51 0           $dbh = $self->make_new_dbh_callback->($self);
52 0 0         die "Could not get a DB handle for getting a lock"
53             if not defined $dbh;
54 0           $self->dbh($dbh);
55             }
56              
57 0           return $dbh;
58             }
59              
60             sub _get_lock {
61 0     0     my $self = shift;
62              
63 0           my $dbh = $self->_get_dbh;
64 0           my $lock_name_base = $self->lock_name;
65 0           my $timeout = $self->timeout;
66 0           for my $worker (1 .. $self->{max_procs}) {
67 0           my $lock_name = $lock_name_base . "_" . $worker;
68 0           my $query = "SELECT GET_LOCK(?, ?)";
69 0           my $res = $dbh->selectcol_arrayref($query, undef, $lock_name, $timeout);
70 0 0 0       if (not defined $res or not ref($res) eq 'ARRAY') {
71 0           die "Failed to execute query '$query': " . $dbh->errstr;
72             }
73 0 0 0       if (@$res && $res->[0]) {
74 0           $self->id($worker);
75 0           last;
76             }
77             }
78              
79 0 0         return undef if not $self->{id};
80 0           return 1;
81             }
82              
83             sub _release_lock {
84 0     0     my $self = shift;
85 0           my $dbh = $self->dbh;
86 0 0         return if not $dbh;
87 0           my $id = $self->id;
88 0 0         return if not $id;
89 0           my $query = "SELECT RELEASE_LOCK(?)";
90 0           $dbh->do($query, undef, $self->lock_name . "_" . $id);
91             }
92              
93             sub DESTROY {
94 0     0     my $self = shift;
95 0           $self->_release_lock();
96             }
97              
98             1;
99              
100             __END__