File Coverage

blib/lib/Mail/Box/Locker/DotLock.pm
Criterion Covered Total %
statement 55 71 77.4
branch 12 34 35.2
condition 1 6 16.6
subroutine 13 14 92.8
pod 4 5 80.0
total 85 130 65.3


line stmt bran cond sub pod time code
1             # Copyrights 2001-2020 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::DotLock;
10 2     2   2198 use vars '$VERSION';
  2         5  
  2         126  
11             $VERSION = '3.009';
12              
13 2     2   12 use base 'Mail::Box::Locker';
  2         10  
  2         636  
14              
15 2     2   16 use strict;
  2         4  
  2         39  
16 2     2   9 use warnings;
  2         5  
  2         61  
17              
18 2     2   11 use IO::File;
  2         3  
  2         307  
19 2     2   15 use File::Spec;
  2         3  
  2         59  
20 2     2   10 use Errno qw/EEXIST/;
  2         5  
  2         262  
21 2     2   14 use Carp;
  2         4  
  2         1556  
22              
23              
24             sub init($)
25 1     1 0 15 { my ($self, $args) = @_;
26 1 50       5 $args->{file} = $args->{dotlock_file} if $args->{dotlock_file};
27 1         7 $self->SUPER::init($args);
28             }
29              
30             sub name() {'DOTLOCK'}
31              
32             sub folder(;$)
33 1     1 1 2 { my $self = shift;
34 1 50 33     48 @_ && $_[0] or return $self->SUPER::folder;
35              
36 1         2 my $folder = shift;
37 1 50       7 unless(defined $self->filename)
38 0         0 { my $org = $folder->organization;
39              
40 0 0       0 my $filename
    0          
41             = $org eq 'FILE' ? $folder->filename . '.lock'
42             : $org eq 'DIRECTORY'? File::Spec->catfile($folder->directory,'.lock')
43             : croak "Need lock file name for DotLock.";
44              
45 0         0 $self->filename($filename);
46             }
47              
48 1         6 $self->SUPER::folder($folder);
49             }
50              
51             sub _try_lock($)
52 1     1   4 { my ($self, $lockfile) = @_;
53 1 50       14 return if -e $lockfile;
54              
55 1 50       7 my $flags = $^O eq 'MSWin32'
56             ? O_CREAT|O_EXCL|O_WRONLY
57             : O_CREAT|O_EXCL|O_WRONLY|O_NONBLOCK;
58              
59 1         9 my $lock = IO::File->new($lockfile, $flags, 0600);
60 1 50       173 if($lock)
61 1         11 { close $lock;
62 1         17 return 1;
63             }
64              
65 0 0       0 if($! != EEXIST)
66 0         0 { $self->log(ERROR => "lockfile $lockfile can never be created: $!");
67 0         0 return 1;
68             }
69             }
70              
71              
72             sub unlock()
73 1     1 1 298 { my $self = shift;
74 1 50       4 $self->hasLock
75             or return $self;
76              
77 1         3 my $lock = $self->filename;
78              
79 1 50       62 unlink $lock
80             or $self->log(WARNING => "Couldn't remove lockfile $lock: $!");
81              
82 1         11 $self->SUPER::unlock;
83 1         3 $self;
84             }
85              
86              
87             sub lock()
88 2     2 1 1165 { my $self = shift;
89              
90 2         7 my $lockfile = $self->filename;
91 2 100       12 if($self->hasLock)
92 1         14 { $self->log(WARNING => "Folder already locked with file $lockfile");
93 1         51 return 1;
94             }
95              
96 1         5 my $timeout = $self->timeout;
97 1 50       5 my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
98 1         6 my $expire = $self->expires/86400; # in days for -A
99              
100 1         2 while(1)
101             {
102 1 50       4 return $self->SUPER::lock
103             if $self->_try_lock($lockfile);
104              
105 0 0 0       if(-e $lockfile && -A $lockfile > $expire)
106             {
107 0 0         if(unlink $lockfile)
108 0           { $self->log(WARNING => "Removed expired lockfile $lockfile");
109 0           redo;
110             }
111             else
112 0           { $self->log(ERROR =>
113             "Failed to remove expired lockfile $lockfile: $!");
114 0           last;
115             }
116             }
117              
118 0 0         last unless --$end;
119 0           sleep 1;
120             }
121              
122 0           return 0;
123             }
124              
125 0     0 1   sub isLocked() { -e shift->filename }
126              
127             1;
128