File Coverage

blib/lib/Mail/Box/Locker/Mutt.pm
Criterion Covered Total %
statement 15 57 26.3
branch 0 20 0.0
condition 0 8 0.0
subroutine 5 11 45.4
pod 4 6 66.6
total 24 102 23.5


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::Mutt;
10 2     2   1159 use vars '$VERSION';
  2         3  
  2         84  
11             $VERSION = '3.008';
12              
13 2     2   10 use base 'Mail::Box::Locker';
  2         3  
  2         169  
14              
15 2     2   13 use strict;
  2         4  
  2         44  
16 2     2   8 use warnings;
  2         3  
  2         79  
17              
18 2     2   10 use POSIX qw/sys_wait_h/;
  2         4  
  2         16  
19              
20              
21             sub init($)
22 0     0 0   { my ($self, $args) = @_;
23 0           $self->SUPER::init($args);
24              
25 0   0       $self->{MBLM_exe} = $args->{exe} || 'mutt_dotlock';
26 0           $self;
27             }
28              
29             sub name() {'MUTT'}
30 0     0 0   sub lockfile() { shift->filename . '.lock' }
31              
32              
33              
34 0     0 1   sub exe() {shift->{MBLM_exe}}
35              
36              
37              
38             sub unlock()
39 0     0 1   { my $self = shift;
40 0 0         $self->hasLock
41             or return $self;
42              
43 0 0         unless(system($self->exe, '-u', $self->filename))
44 0           { my $folder = $self->folder;
45 0           $self->log(WARNING => "Couldn't remove mutt-unlock $folder: $!");
46             }
47              
48 0           $self->SUPER::unlock;
49 0           $self;
50             }
51              
52              
53              
54             sub lock()
55 0     0 1   { my $self = shift;
56 0           my $folder = $self->folder;
57 0 0         if($self->hasLock)
58 0           { $self->log(WARNING => "Folder $folder already mutt-locked");
59 0           return 1;
60             }
61              
62 0           my $filename = $self->filename;
63 0           my $lockfn = $self->lockfile;
64              
65 0           my $timeout = $self->timeout;
66 0 0         my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
67 0           my $expire = $self->expires / 86400; # in days for -A
68 0           my $exe = $self->exe;
69              
70 0           while(1)
71             {
72 0 0         if(system($exe, '-p', '-r', 1, $filename))
73 0 0 0       { unless(WIFEXITED($?) && WEXITSTATUS($?)==3)
74 0           { $self->log(ERROR => "Will never get a mutt-lock: $!");
75 0           return 0;
76             }
77             }
78             else
79 0           { return $self->SUPER::lock;
80             }
81              
82 0 0 0       if(-e $lockfn && -A $lockfn > $expire)
83             {
84 0 0         if(system($exe, '-f', '-u', $filename))
85 0           { $self->log(ERROR =>
86             "Failed to remove expired mutt-lock $lockfn: $!");
87 0           last;
88             }
89             else
90 0           { $self->log(WARNING => "Removed expired mutt-lock $lockfn");
91 0           redo;
92             }
93             }
94              
95 0 0         last unless --$end;
96 0           sleep 1;
97             }
98              
99 0           return 0;
100             }
101              
102              
103             sub isLocked()
104 0     0 1   { my $self = shift;
105 0           system($self->exe, '-t', $self->filename);
106 0 0         WIFEXITED($?) && WEXITSTATUS($?)==3;
107             }
108              
109             1;
110