File Coverage

blib/lib/Mail/Box/Locker/Multi.pm
Criterion Covered Total %
statement 48 62 77.4
branch 11 22 50.0
condition n/a
subroutine 10 11 90.9
pod 4 5 80.0
total 73 100 73.0


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::Multi;
10 2     2   1401 use vars '$VERSION';
  2         5  
  2         103  
11             $VERSION = '3.008';
12              
13 2     2   10 use base 'Mail::Box::Locker';
  2         8  
  2         513  
14              
15 2     2   12 use strict;
  2         3  
  2         32  
16 2     2   8 use warnings;
  2         2  
  2         49  
17              
18 2     2   9 use Carp;
  2         4  
  2         1013  
19              
20              
21             sub init($)
22 1     1 0 14 { my ($self, $args) = @_;
23 1         7 $self->SUPER::init($args);
24              
25             my @use
26 1 50       7 = exists $args->{use} ? @{delete $args->{use}}
  0 50       0  
27             : $^O eq 'MSWin32' ? qw/Flock/
28             : qw/NFS FcntlLock Flock/;
29              
30 1         2 my (@lockers, @used);
31              
32 1         3 foreach my $method (@use)
33 3 50       14 { if(UNIVERSAL::isa($method, 'Mail::Box::Locker'))
34 0         0 { push @lockers, $method;
35 0         0 (my $used = ref $method) =~ s/.*\:\://;
36 0         0 push @used, $used;
37 0         0 next;
38             }
39              
40             my $locker = eval
41 3         5 { Mail::Box::Locker->new
  3         14  
42             ( %$args
43             , method => $method
44             , timeout => 1
45             )
46             };
47 3 100       148 next unless defined $locker;
48              
49 2         4 push @lockers, $locker;
50 2         5 push @used, $method;
51             }
52              
53 1         3 $self->{MBLM_lockers} = \@lockers;
54 1         10 $self->log(PROGRESS => "Multi-locking via @used.");
55 1         26 $self;
56             }
57              
58             #-------------------------------------------
59              
60             sub name() {'MULTI'}
61              
62             sub _try_lock($)
63 1     1   2 { my $self = shift;
64 1         2 my @successes;
65              
66 1         3 foreach my $locker ($self->lockers)
67             {
68 2 50       6 unless($locker->lock)
69 0         0 { $_->unlock foreach @successes;
70 0         0 return 0;
71             }
72 2         5 push @successes, $locker;
73             }
74              
75 1         6 1;
76             }
77              
78             sub unlock()
79 1     1 1 2 { my $self = shift;
80 1 50       3 $self->hasLock
81             or return $self;
82              
83 1         3 $_->unlock foreach $self->lockers;
84 1         4 $self->SUPER::unlock;
85              
86 1         10 $self;
87             }
88              
89             sub lock()
90 2     2 1 784 { my $self = shift;
91 2 100       8 return 1 if $self->hasLock;
92              
93 1         5 my $timeout = $self->timeout;
94 1 50       5 my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
95              
96 1         2 while(1)
97 1 50       3 { return $self->SUPER::lock
98             if $self->_try_lock;
99              
100 0 0       0 last unless --$end;
101 0         0 sleep 1;
102             }
103              
104 0         0 return 0;
105             }
106              
107             sub isLocked()
108 0     0 1 0 { my $self = shift;
109              
110             # Try get a lock
111 0 0       0 $self->_try_lock($self->filename) or return 0;
112              
113             # and release it immediately
114 0         0 $self->unlock;
115 0         0 1;
116             }
117              
118             #-------------------------------------------
119              
120              
121 2     2 1 3 sub lockers() { @{shift->{MBLM_lockers}} }
  2         9  
122              
123             1;