1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
# This code is part of Perl distribution Mail-Box version 4.01.
# The POD got stripped from this file by OODoc version 3.05.
# For contributors see file ChangeLog.
# This software is copyright (c) 2001-2025 by Mark Overmeer.
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later
package Mail::Box::Locker::NFS;{
our $VERSION = '4.01';
}
use parent 'Mail::Box::Locker';
use strict;
use warnings;
use Log::Report 'mail-box', import => [ qw/__x fault warning/ ];
use Sys::Hostname qw/hostname/;
use Fcntl qw/O_CREAT O_WRONLY/;
#--------------------
sub name() { 'NFS' }
#--------------------
# METHOD nfs
# This hack is copied from the Mail::Folder packages, as written
# by Kevin Jones. Cited from his code:
# Whhheeeee!!!!!
# In NFS, the O_CREAT|O_EXCL isn't guaranteed to be atomic.
# So we create a temp file that is probably unique in space
# and time ($folder.lock.$time.$pid.$host).
# Then we use link to create the real lock file. Since link
# is atomic across nfs, this works.
# It loses if it's on a filesystem that doesn't do long filenames.
my $hostname = hostname;
sub _tmpfilename()
{ my $self = shift;
$self->{MBLN_tmp} ||= $self->filename . $$;
}
sub _construct_tmpfile()
{ my $self = shift;
my $tmpfile = $self->_tmpfilename;
sysopen my $fh, $tmpfile, O_CREAT|O_WRONLY, 0600
or return undef;
$fh->close;
$tmpfile;
}
sub _try_lock($$)
{ my ($self, $tmpfile, $lockfile) = @_;
link $tmpfile, $lockfile
or return undef;
my $linkcount = (stat $tmpfile)[3];
unlink $tmpfile;
$linkcount == 2;
}
sub lock()
{ my $self = shift;
my $folder = $self->folder;
$self->hasLock
and warning(__x"folder {name} already locked over NFS.", name => $folder), return 1;
my $lockfile = $self->filename;
my $tmpfile = $self->_construct_tmpfile or return;
my $timeout = $self->timeout;
my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
my $expires = $self->expires / 86400; # in days for -A
if(-e $lockfile && -A $lockfile > $expires)
{ unlink $lockfile
or fault __x"Unable to remove expired lockfile {file}", file => $lockfile;
warning __x"removed expired lockfile {file}.", file => $lockfile;
}
while(1)
{ return $self->SUPER::lock
if $self->_try_lock($tmpfile, $lockfile);
--$end or last;
sleep 1;
}
return 0;
}
sub isLocked()
{ my $self = shift;
my $tmpfile = $self->_construct_tmpfile or return 0;
my $lockfile = $self->filename;
my $fh = $self->_try_lock($tmpfile, $lockfile) or return 0;
close $fh;
$self->_unlock($tmpfile, $lockfile);
$self->SUPER::unlock;
1;
}
sub _unlock($$)
{ my ($self, $tmpfile, $lockfile) = @_;
unlink $lockfile
or fault __x"couldn't remove lockfile {file}", file => $lockfile;
unlink $tmpfile;
$self;
}
sub unlock($)
{ my $self = shift;
$self->hasLock or return $self;
$self->_unlock($self->_tmpfilename, $self->filename);
$self->SUPER::unlock;
$self;
}
1;
|
