File Coverage

blib/lib/JIP/LockFile.pm
Criterion Covered Total %
statement 83 91 91.2
branch 22 28 78.5
condition 1 2 50.0
subroutine 23 23 100.0
pod 3 8 37.5
total 132 152 86.8


line stmt bran cond sub pod time code
1             package JIP::LockFile;
2              
3 1     1   95160 use 5.006;
  1         4  
4 1     1   5 use strict;
  1         2  
  1         20  
5 1     1   5 use warnings;
  1         2  
  1         35  
6              
7 1     1   438 use IO::File;
  1         966  
  1         110  
8 1     1   6 use Carp qw(croak);
  1         2  
  1         38  
9 1     1   5 use Fcntl qw(LOCK_EX LOCK_NB);
  1         2  
  1         35  
10 1     1   5 use English qw(-no_match_vars);
  1         2  
  1         7  
11              
12             our $VERSION = '0.063';
13              
14             sub new {
15 16     16 0 34526 my ( $class, %param ) = @ARG;
16              
17             # Mandatory options
18 16 100       52 if ( !exists $param{lock_file} ) {
19 1         169 croak q{Mandatory argument "lock_file" is missing};
20             }
21              
22             # Check "lock_file"
23 15         28 my $lock_file = $param{lock_file};
24 15 100       36 if ( !length $lock_file ) {
25 2         182 croak q{Bad argument "lock_file"};
26             }
27              
28             # Class to object
29 13         103 return bless(
30             {
31             is_locked => 0,
32             fh => undef,
33             error => undef,
34             lock_file => $lock_file,
35             },
36             $class,
37             );
38             } ## end sub new
39              
40             sub is_locked {
41 40     40 1 67 my ($self) = @ARG;
42              
43 40         162 return $self->{is_locked};
44             }
45              
46             sub lock_file {
47 26     26 1 1351 my ($self) = @ARG;
48              
49 26         5715 return $self->{lock_file};
50             }
51              
52             sub error {
53 5     5 1 773 my ($self) = @ARG;
54              
55 5         119 return $self->{error};
56             }
57              
58             # Lock or raise an exception
59             sub lock {
60 6     6 0 20 my ($self) = @ARG;
61              
62 6         14 return $self->_lock();
63             }
64              
65             # Or just return undef
66             sub try_lock {
67 4     4 0 11 my ($self) = @ARG;
68              
69 4         10 return $self->_lock( try => 1 );
70             }
71              
72             # You can manually unlock
73             sub unlock {
74 15     15 0 22 my ($self) = @ARG;
75              
76             # Re-unlocking changes nothing
77 15 100       32 return $self if !$self->is_locked();
78              
79             # Close filehandle before file removing
80 6         22 $self->_set_fh(undef);
81              
82 6 50       24 if ( !unlink $self->lock_file() ) {
83 0         0 $self->_set_error($OS_ERROR);
84              
85 0         0 croak sprintf( q{Can't unlink "%s": %s}, $self->lock_file(), $self->error() );
86             }
87              
88 6         46 return $self->_set_is_locked(0);
89             }
90              
91             sub get_lock_data {
92 9     9 0 26 my ($self) = @_;
93              
94 9         12 my $line;
95             {
96 9 100       12 my $fh
  9         19  
97             = $self->is_locked()
98             ? $self->_fh()
99             : $self->_init_file_handle();
100              
101 9 50       22 return if !$fh;
102              
103 9         42 $fh->seek( 0, 0 );
104              
105 9         333 $line = $fh->getline();
106             }
107              
108 9 100       460 return if !$line;
109              
110 8         16 chomp $line;
111              
112 8         55 my ( $pid, $executable_name ) = $line =~ m{
113             ^
114             {
115             "pid":"(\d+)"
116             ,
117             "executable_name":"( [^""]+ )"
118             }
119             $
120             }x;
121              
122             return {
123 8         113 pid => $pid,
124             executable_name => $executable_name,
125             };
126             } ## end sub get_lock_data
127              
128             # unlocking on scope exit
129             sub DESTROY {
130 13     13   4994 my ($self) = @ARG;
131              
132 13         34 return $self->unlock();
133             }
134              
135             sub _init_file_handle {
136 11     11   59 my ($self) = @ARG;
137              
138 11         24 my $fh = IO::File->new( $self->lock_file(), O_RDWR | O_CREAT );
139              
140 11 50       1366 if ( !$fh ) {
141 0         0 $self->_set_error($OS_ERROR);
142             }
143              
144 11         23 return $fh;
145             }
146              
147             sub _lock {
148 10     10   25 my ( $self, %param ) = @_;
149              
150             # Re-locking changes nothing
151 10 100       20 return $self if $self->is_locked();
152              
153 8         22 my $fh = $self->_init_file_handle();
154              
155 8 50       19 if ( !$fh ) {
156 0         0 croak sprintf( q{Can't open "%s": %s}, $self->lock_file(), $self->error() );
157             }
158              
159 8 100       90 if ( !flock $fh, LOCK_EX | LOCK_NB ) {
160 2         10 $self->_set_error($OS_ERROR);
161              
162 2 100       69 return if $param{try};
163              
164 1         3 croak sprintf( q{Can't lock "%s": %s}, $self->lock_file(), $self->error() );
165             }
166              
167 6 50       151 if ( !truncate $fh, 0 ) {
168 0         0 $self->_set_error($OS_ERROR);
169              
170 0         0 croak sprintf( q{Can't truncate "%s": %s}, $self->lock_file(), $self->error() );
171             }
172              
173 6         44 autoflush $fh 1;
174              
175 6 50       304 if ( !$fh->print( $self->_lock_message() ) ) {
176 0         0 $self->_set_error($OS_ERROR);
177              
178 0         0 croak sprintf( q{Can't write message to file: %s}, $self->error() );
179             }
180              
181 6         388 return $self->_set_fh($fh)->_set_is_locked(1);
182             } ## end sub _lock
183              
184             sub _lock_message {
185 6     6   50 return sprintf(
186             q[{"pid":"%s","executable_name":"%s"}],
187             $PROCESS_ID,
188             $EXECUTABLE_NAME,
189             );
190             }
191              
192             sub _set_is_locked {
193 12     12   35 my ( $self, $is_locked ) = @ARG;
194              
195 12         26 $self->{is_locked} = $is_locked;
196              
197 12         124 return $self;
198             }
199              
200             sub _fh {
201 6     6   9 my ($self) = @ARG;
202              
203 6         10 return $self->{fh};
204             }
205              
206             sub _set_fh {
207 12     12   29 my ( $self, $fh ) = @ARG;
208              
209 12         407 $self->{fh} = $fh;
210              
211 12         42 return $self;
212             }
213              
214             sub _set_error {
215 2     2   15 my ( $self, $error ) = @ARG;
216              
217 2   50     8 $self->{error} = $error || '';
218              
219 2         4 return $self;
220             }
221              
222             1;
223              
224             __END__