File Coverage

blib/lib/Mail/Box/Locker/POSIX.pm
Criterion Covered Total %
statement 51 71 71.8
branch 7 20 35.0
condition 1 3 33.3
subroutine 12 13 92.3
pod 3 4 75.0
total 74 111 66.6


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::POSIX;
10 2     2   1946 use vars '$VERSION';
  2         4  
  2         113  
11             $VERSION = '3.010';
12              
13 2     2   11 use base 'Mail::Box::Locker';
  2         19  
  2         568  
14              
15 2     2   14 use strict;
  2         4  
  2         85  
16 2     2   10 use warnings;
  2         4  
  2         55  
17              
18 2     2   83 use Fcntl;
  2         8  
  2         819  
19 2     2   15 use IO::File;
  2         5  
  2         320  
20 2     2   13 use Errno qw/EAGAIN/;
  2         4  
  2         1510  
21              
22             # fcntl() should not be used without XS: the below is sensitive
23             # for changes in the structure. However, at the moment it seems
24             # there are only two options: either SysV-style or BSD-style
25              
26             my $pack_pattern = $^O =~ /bsd|darwin/i ? '@20 s @256' : 's @256';
27              
28              
29             sub init($)
30 1     1 0 15 { my ($self, $args) = @_;
31 1 50       4 $args->{file} = $args->{posix_file} if $args->{posix_file};
32 1         7 $self->SUPER::init($args);
33             }
34              
35             sub name() {'POSIX'}
36              
37             sub _try_lock($)
38 1     1   4 { my ($self, $file) = @_;
39 1         9 my $p = pack $pack_pattern, F_WRLCK;
40 1   33     20 $? = fcntl($file, F_SETLK, $p) || ($!+0);
41 1         6 $?==0;
42             }
43              
44             sub _unlock($)
45 1     1   3 { my ($self, $file) = @_;
46 1         6 my $p = pack $pack_pattern, F_UNLCK;
47 1         21 fcntl $file, F_SETLK, $p;
48 1         4 $self;
49             }
50              
51              
52              
53             sub lock()
54 2     2 1 1650 { my $self = shift;
55              
56 2 100       11 if($self->hasLock)
57 1         3 { my $folder = $self->folder;
58 1         6 $self->log(WARNING => "Folder $folder already lockf'd");
59 1         49 return 1;
60             }
61              
62 1         9 my $filename = $self->filename;
63 1         4 my $folder = $self->folder;
64              
65 1         9 my $file = IO::File->new($filename, 'r+');
66 1 50       148 unless(defined $file)
67 0         0 { $self->log(ERROR =>
68             "Unable to open POSIX lock file $filename for $folder: $!");
69 0         0 return 0;
70             }
71              
72 1         11 my $timeout = $self->timeout;
73 1 50       5 my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
74              
75 1         2 while(1)
76 1 50       3 { if($self->_try_lock($file))
77 1         5 { $self->{MBLF_filehandle} = $file;
78 1         17 return $self->SUPER::lock;
79             }
80              
81 0 0       0 unless($!==EAGAIN)
82 0         0 { $self->log(ERROR =>
83             "Will never get a POSIX lock on $filename for $folder: $!");
84 0         0 last;
85             }
86              
87 0 0       0 last unless --$end;
88 0         0 sleep 1;
89             }
90              
91 0         0 return 0;
92             }
93              
94              
95             sub isLocked()
96 0     0 1 0 { my $self = shift;
97 0         0 my $filename = $self->filename;
98              
99 0         0 my $file = IO::File->new($filename, "r");
100 0 0       0 unless($file)
101 0         0 { my $folder = $self->folder;
102 0         0 $self->log(ERROR => "Unable to check lock file $filename for $folder: $!");
103 0         0 return 0;
104             }
105              
106 0 0       0 $self->_try_lock($file)==0 or return 0;
107 0         0 $self->_unlock($file);
108 0         0 $file->close;
109              
110 0         0 $self->SUPER::unlock;
111 0         0 1;
112             }
113              
114             sub unlock()
115 1     1 1 429 { my $self = shift;
116              
117             $self->_unlock(delete $self->{MBLF_filehandle})
118 1 50       4 if $self->hasLock;
119              
120 1         24 $self->SUPER::unlock;
121 1         3 $self;
122             }
123              
124             1;