File Coverage

blib/lib/Mail/Box/Locker/NFS.pm
Criterion Covered Total %
statement 55 69 79.7
branch 10 26 38.4
condition 3 6 50.0
subroutine 13 14 92.8
pod 3 3 100.0
total 84 118 71.1


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::NFS;
10 3     3   1345 use vars '$VERSION';
  3         6  
  3         151  
11             $VERSION = '3.008';
12              
13 3     3   14 use base 'Mail::Box::Locker';
  3         11  
  3         834  
14              
15 3     3   19 use strict;
  3         5  
  3         49  
16 3     3   12 use warnings;
  3         5  
  3         66  
17              
18 3     3   14 use Sys::Hostname;
  3         5  
  3         123  
19 3     3   13 use IO::File;
  3         5  
  3         388  
20 3     3   15 use Carp;
  3         6  
  3         1605  
21              
22              
23             sub name() {'NFS'}
24              
25             #-------------------------------------------
26              
27             # METHOD nfs
28             # This hack is copied from the Mail::Folder packages, as written
29             # by Kevin Jones. Cited from his code:
30             # Whhheeeee!!!!!
31             # In NFS, the O_CREAT|O_EXCL isn't guaranteed to be atomic.
32             # So we create a temp file that is probably unique in space
33             # and time ($folder.lock.$time.$pid.$host).
34             # Then we use link to create the real lock file. Since link
35             # is atomic across nfs, this works.
36             # It loses if it's on a filesystem that doesn't do long filenames.
37              
38             my $hostname = hostname;
39              
40             sub _tmpfilename()
41 4     4   6 { my $self = shift;
42 4   66     19 $self->{MBLN_tmp} ||= $self->filename . $$;
43             }
44              
45             sub _construct_tmpfile()
46 2     2   4 { my $self = shift;
47 2         5 my $tmpfile = $self->_tmpfilename;
48              
49 2 50       14 my $fh = IO::File->new($tmpfile, O_CREAT|O_WRONLY, 0600)
50             or return undef;
51              
52 2         460 $fh->close;
53 2         44 $tmpfile;
54             }
55              
56             sub _try_lock($$)
57 2     2   7 { my ($self, $tmpfile, $lockfile) = @_;
58              
59             return undef
60 2 50       54 unless link $tmpfile, $lockfile;
61              
62 2         25 my $linkcount = (stat $tmpfile)[3];
63              
64 2         58 unlink $tmpfile;
65 2         24 $linkcount == 2;
66             }
67              
68             sub _unlock($$)
69 2     2   5 { my ($self, $tmpfile, $lockfile) = @_;
70              
71 2 50       81 unlink $lockfile
72             or warn "Couldn't remove lockfile $lockfile: $!\n";
73              
74 2         26 unlink $tmpfile;
75              
76 2         7 $self;
77             }
78              
79             #-------------------------------------------
80              
81              
82             sub lock()
83 3     3 1 7099 { my $self = shift;
84 3         10 my $folder = $self->folder;
85              
86 3 100       13 if($self->hasLock)
87 1         6 { $self->log(WARNING => "Folder $folder already locked over nfs");
88 1         42 return 1;
89             }
90              
91 2         9 my $lockfile = $self->filename;
92 2 50       6 my $tmpfile = $self->_construct_tmpfile or return;
93 2         16 my $timeout = $self->timeout;
94 2 50       8 my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
95 2         10 my $expires = $self->expires / 86400; # in days for -A
96              
97 2 50 33     24 if(-e $lockfile && -A $lockfile > $expires)
98 0 0       0 { if(unlink $lockfile)
99 0         0 { $self->log(WARNING => "Removed expired lockfile $lockfile.") }
100 0         0 else { $self->log(ERROR =>
101             "Unable to remove expired lockfile $lockfile: $!") }
102             }
103              
104 2         5 while(1)
105 2 50       14 { return $self->SUPER::lock
106             if $self->_try_lock($tmpfile, $lockfile);
107              
108 0 0       0 last unless --$end;
109 0         0 sleep 1;
110             }
111              
112 0         0 return 0;
113             }
114              
115             #-------------------------------------------
116              
117             sub isLocked()
118 0     0 1 0 { my $self = shift;
119 0 0       0 my $tmpfile = $self->_construct_tmpfile or return 0;
120 0         0 my $lockfile = $self->filename;
121              
122 0 0       0 my $fh = $self->_try_lock($tmpfile, $lockfile) or return 0;
123              
124 0         0 close $fh;
125 0         0 $self->_unlock($tmpfile, $lockfile);
126 0         0 $self->SUPER::unlock;
127              
128 0         0 1;
129             }
130              
131             #-------------------------------------------
132              
133             sub unlock($)
134 2     2 1 2552 { my $self = shift;
135 2 50       7 return $self unless $self->hasLock;
136              
137 2         6 $self->_unlock($self->_tmpfilename, $self->filename);
138 2         15 $self->SUPER::unlock;
139 2         5 $self;
140             }
141              
142             #-------------------------------------------
143              
144             1;