File Coverage

blib/lib/Mail/Box/Locker/FcntlLock.pm
Criterion Covered Total %
statement 22 24 91.6
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 30 32 93.7


line stmt bran cond sub pod time code
1             # Copyrights 2001-2023 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.03.
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::FcntlLock;
10 1     1   7 use vars '$VERSION';
  1         2  
  1         57  
11             $VERSION = '3.010';
12              
13 1     1   6 use base 'Mail::Box::Locker';
  1         2  
  1         90  
14              
15 1     1   7 use strict;
  1         2  
  1         18  
16 1     1   4 use warnings;
  1         2  
  1         23  
17              
18 1     1   5 use Fcntl;
  1         2  
  1         296  
19 1     1   7 use IO::File;
  1         2  
  1         148  
20 1     1   7 use Errno qw/EAGAIN/;
  1         2  
  1         141  
21 1     1   252 use File::FcntlLock;
  0            
  0            
22              
23              
24              
25             sub init($)
26             { my ($self, $args) = @_;
27             $args->{file} = $args->{posix_file} if $args->{posix_file};
28             $self->SUPER::init($args);
29             }
30              
31             sub name() {'FcntlLock'}
32              
33             sub _try_lock($)
34             { my ($self, $file) = @_;
35             my $fl = File::FcntlLock->new;
36             $fl->l_type(F_WRLCK);
37             $? = $fl->lock($file, F_SETLK);
38             $?==0;
39             }
40              
41             sub _unlock($)
42             { my ($self, $file) = @_;
43             my $fl = File::FcntlLock->new;
44             $fl->l_type(F_UNLCK);
45             $fl->lock($file, F_SETLK);
46             $self;
47             }
48              
49              
50             sub lock()
51             { my $self = shift;
52              
53             if($self->hasLock)
54             { my $folder = $self->folder;
55             $self->log(WARNING => "Folder $folder already lockf'd");
56             return 1;
57             }
58              
59             my $filename = $self->filename;
60              
61             my $file = IO::File->new($filename, 'r+');
62             unless(defined $file)
63             { my $folder = $self->folder;
64             $self->log(ERROR =>
65             "Unable to open FcntlLock lock file $filename for $folder: $!");
66             return 0;
67             }
68              
69             my $timeout = $self->timeout;
70             my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
71              
72             while(1)
73             { if($self->_try_lock($file))
74             { $self->SUPER::lock;
75             $self->{MBLF_filehandle} = $file;
76             return 1;
77             }
78              
79             unless($!==EAGAIN)
80             { my $folder = $self->folder;
81             $self->log(ERROR =>
82             "Will never get a FcntlLock lock on $filename for $folder: $!");
83             last;
84             }
85              
86             last unless --$end;
87             sleep 1;
88             }
89              
90             return 0;
91             }
92              
93              
94              
95             sub isLocked()
96             { my $self = shift;
97             my $filename = $self->filename;
98              
99             my $file = IO::File->new($filename, "r");
100             unless($file)
101             { my $folder = $self->folder;
102             $self->log(ERROR =>
103             "Unable to check lock file $filename for $folder: $!");
104             return 0;
105             }
106              
107             $self->_try_lock($file)==0 or return 0;
108             $self->_unlock($file);
109             $file->close;
110              
111             $self->SUPER::unlock;
112             1;
113             }
114              
115             sub unlock()
116             { my $self = shift;
117              
118             $self->_unlock(delete $self->{MBLF_filehandle})
119             if $self->hasLock;
120              
121             $self->SUPER::unlock;
122             $self;
123             }
124              
125             1;