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
|
# 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::Multi;{
our $VERSION = '4.01';
}
use parent 'Mail::Box::Locker';
use strict;
use warnings;
use Log::Report 'mail-box', import => [ qw/trace try/ ];
use Scalar::Util qw/blessed/;
#--------------------
sub init($)
{ my ($self, $args) = @_;
$self->SUPER::init($args);
my @use
= exists $args->{use} ? @{delete $args->{use}}
: $^O eq 'MSWin32' ? qw/Flock/
: qw/NFS FcntlLock Flock/;
my (@lockers, @used);
foreach my $method (@use)
{ if(blessed $method && $method->isa('Mail::Box::Locker'))
{ push @lockers, $method;
push @used, ref $method =~ s/.*\:\://r;
next;
}
my $locker = try { Mail::Box::Locker->new(%$args, method => $method, timeout => 1) };
defined $locker or next;
push @lockers, $locker;
push @used, $method;
}
$self->{MBLM_lockers} = \@lockers;
trace "Multi-locking via @used.";
$self;
}
#--------------------
sub lockers() { @{ $_[0]->{MBLM_lockers}} }
sub name() {'MULTI'}
sub _try_lock()
{ my $self = shift;
my @successes;
foreach my $locker ($self->lockers)
{
unless($locker->lock)
{ $_->unlock for @successes;
return 0;
}
push @successes, $locker;
}
1;
}
#--------------------
sub unlock()
{ my $self = shift;
$self->hasLock or return $self;
$_->unlock for $self->lockers;
$self->SUPER::unlock;
$self;
}
sub lock()
{ my $self = shift;
return 1 if $self->hasLock;
my $timeout = $self->timeout;
my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
while(1)
{ return $self->SUPER::lock
if $self->_try_lock;
last unless --$end;
sleep 1;
}
return 0;
}
sub isLocked()
{ my $self = shift;
# Try get a lock
$self->_try_lock or return 0;
# and release it immediately
$self->unlock;
1;
}
1;
|
