File Coverage

blib/lib/Mail/Box/Locker/Flock.pm
Criterion Covered Total %
statement 44 64 68.7
branch 6 18 33.3
condition n/a
subroutine 11 12 91.6
pod 3 3 100.0
total 64 97 65.9


line stmt bran cond sub pod time code
1             # Copyrights 2001-2019 by [Mark Overmeer].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5             # This code is part of distribution Mail-Box. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package Mail::Box::Locker::Flock;
10 3     3   1406 use vars '$VERSION';
  3         6  
  3         142  
11             $VERSION = '3.008';
12              
13 3     3   15 use base 'Mail::Box::Locker';
  3         9  
  3         546  
14              
15 3     3   17 use strict;
  3         5  
  3         49  
16 3     3   10 use warnings;
  3         5  
  3         75  
17              
18 3     3   13 use IO::File;
  3         5  
  3         377  
19 3     3   16 use Fcntl qw/:DEFAULT :flock/;
  3         4  
  3         1035  
20 3     3   18 use Errno qw/EAGAIN/;
  3         4  
  3         1458  
21              
22              
23             sub name() {'FLOCK'}
24              
25             sub _try_lock($)
26 2     2   6 { my ($self, $file) = @_;
27 2         22 flock $file, LOCK_EX|LOCK_NB;
28             }
29              
30             sub _unlock($)
31 2     2   4 { my ($self, $file) = @_;
32 2         15 flock $file, LOCK_UN;
33 2         6 $self;
34             }
35              
36              
37              
38             # 'r+' is require under Solaris and AIX, other OSes are satisfied with 'r'.
39             my $lockfile_access_mode = ($^O eq 'solaris' || $^O eq 'aix') ? 'r+' : 'r';
40              
41             sub lock()
42 3     3 1 923 { my $self = shift;
43 3         8 my $folder = $self->folder;
44              
45 3 100       20 if($self->hasLock)
46 1         13 { $self->log(WARNING => "Folder $folder already flocked.");
47 1         41 return 1;
48             }
49              
50 2         9 my $filename = $self->filename;
51              
52 2         13 my $file = IO::File->new($filename, $lockfile_access_mode);
53 2 50       197 unless($file)
54 0         0 { $self->log(ERROR =>
55             "Unable to open flock file $filename for $folder: $!");
56 0         0 return 0;
57             }
58              
59 2         14 my $timeout = $self->timeout;
60 2 50       8 my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
61              
62 2         3 while(1)
63 2 50       18 { if($self->_try_lock($file))
64 2         7 { $self->{MBLF_filehandle} = $file;
65 2         10 return $self->SUPER::lock;
66             }
67              
68 0 0       0 if($! != EAGAIN)
69 0         0 { $self->log(ERROR =>
70             "Will never get a flock on $filename for $folder: $!");
71 0         0 last;
72             }
73              
74 0 0       0 last unless --$end;
75 0         0 sleep 1;
76             }
77              
78 0         0 return 0;
79             }
80              
81              
82             sub isLocked()
83 0     0 1 0 { my $self = shift;
84 0         0 my $filename = $self->filename;
85              
86 0         0 my $file = IO::File->new($filename, $lockfile_access_mode);
87 0 0       0 unless($file)
88 0         0 { my $folder = $self->folder;
89 0         0 $self->log(ERROR =>
90             "Unable to check lock file $filename for $folder: $!");
91 0         0 return 0;
92             }
93              
94 0 0       0 $self->_try_lock($file) or return 0;
95 0         0 $self->_unlock($file);
96 0         0 $file->close;
97              
98 0         0 $self->SUPER::unlock;
99 0         0 1;
100             }
101              
102             sub unlock()
103 2     2 1 224 { my $self = shift;
104              
105             $self->_unlock(delete $self->{MBLF_filehandle})
106 2 50       6 if $self->hasLock;
107              
108 2         41 $self->SUPER::unlock;
109 2         5 $self;
110             }
111              
112             1;