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
|
# 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::POSIX;{
our $VERSION = '4.01';
}
use parent 'Mail::Box::Locker';
use strict;
use warnings;
use Log::Report 'mail-box', import => [ qw/__x error fault warning/ ];
use Fcntl qw/F_WRLCK F_UNLCK F_SETLK/;
use Errno qw/EAGAIN/;
# fcntl() should not be used without XS: the below is sensitive
# for changes in the structure. However, at the moment it seems
# there are only two options: either SysV-style or BSD-style
my $pack_pattern = $^O =~ /bsd|darwin/i ? '@20 s @256' : 's @256';
#--------------------
sub init($)
{ my ($self, $args) = @_;
$args->{file} = $args->{posix_file} if $args->{posix_file};
$self->SUPER::init($args);
}
sub name() { 'POSIX' }
#--------------------
sub _try_lock($)
{ my ($self, $file) = @_;
my $p = pack $pack_pattern, F_WRLCK;
$? = fcntl($file, F_SETLK, $p) || ($!+0);
$?==0;
}
sub _unlock($)
{ my ($self, $file) = @_;
my $p = pack $pack_pattern, F_UNLCK;
fcntl $file, F_SETLK, $p;
$self;
}
sub lock()
{ my $self = shift;
$self->hasLock
and warning(__x"folder {name} already lockf'd.", name => $self->folder), return 1;
my $file = $self->filename;
open my $fh, '+<:raw', $file
or fault __x"unable to open POSIX lock file {file} for {folder}", file => $file, $self->folder;
my $timeout = $self->timeout;
my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
while(1)
{ if($self->_try_lock($fh))
{ $self->{MBLF_filehandle} = $fh;
return $self->SUPER::lock;
}
$!==EAGAIN
or fault __x"will never get a POSIX lock on {file} for {folder}", file => $file, folder => $self->folder;
--$end or last;
sleep 1;
}
return 0;
}
sub isLocked()
{ my $self = shift;
my $file = $self->filename;
open my $fh, '<:raw', $file
or fault __x"unable to check lock file {file} for {folder}", file => $file, folder => $self->folder;
$self->_try_lock($fh)==0 or return 0;
$self->_unlock($fh);
$fh->close;
$self->SUPER::unlock;
1;
}
sub unlock()
{ my $self = shift;
$self->_unlock(delete $self->{MBLF_filehandle})
if $self->hasLock;
$self->SUPER::unlock;
$self;
}
1;
|
