File Coverage

blib/lib/Mutex/Flock.pm
Criterion Covered Total %
statement 41 94 43.6
branch 13 80 16.2
condition 7 24 29.1
subroutine 9 19 47.3
pod 7 7 100.0
total 77 224 34.3


line stmt bran cond sub pod time code
1             ###############################################################################
2             ## ----------------------------------------------------------------------------
3             ## Mutex::Flock - Mutex locking via Fcntl.
4             ##
5             ###############################################################################
6              
7             package Mutex::Flock;
8              
9 2     2   1166 use strict;
  2         4  
  2         62  
10 2     2   9 use warnings;
  2         4  
  2         60  
11              
12 2     2   10 no warnings qw( threads recursion uninitialized once );
  2         4  
  2         103  
13              
14             our $VERSION = '1.011';
15              
16 2     2   11 use base 'Mutex';
  2         3  
  2         289  
17 2     2   15 use Fcntl ':flock';
  2         4  
  2         322  
18 2     2   18 use Scalar::Util 'looks_like_number';
  2         10  
  2         106  
19 2     2   1108 use Time::HiRes 'alarm';
  2         2815  
  2         7  
20              
21             my $tid = $INC{'threads.pm'} ? threads->tid() : 0;
22              
23             sub CLONE {
24 0 0   0   0 $tid = threads->tid() if $INC{'threads.pm'};
25             }
26              
27             sub Mutex::Flock::_guard::DESTROY {
28 0     0   0 my ($pid, $obj) = @{ $_[0] };
  0         0  
29 0 0       0 CORE::flock ($obj->{_fh}, LOCK_UN), $obj->{ $pid } = 0 if $obj->{ $pid };
30              
31 0         0 return;
32             }
33              
34             sub DESTROY {
35 2 50   2   847 my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, @_);
36 2 50       9 $obj->unlock(), close(delete $obj->{_fh}) if $obj->{ $pid };
37 2 100 66     63 unlink $obj->{path} if ($obj->{_init} && $obj->{_init} eq $pid);
38              
39 2         13 return;
40             }
41              
42             sub _open {
43 0 0   0   0 my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, @_);
44 0 0       0 return if exists $obj->{ $pid };
45              
46             open $obj->{_fh}, '+>>:raw:stdio', $obj->{path}
47 0 0       0 or Carp::croak("Could not create temp file $obj->{path}: $!");
48              
49 0         0 return;
50             }
51              
52             ###############################################################################
53             ## ----------------------------------------------------------------------------
54             ## Public methods.
55             ##
56             ###############################################################################
57              
58             my ($id, $prog_name) = (0);
59              
60             $prog_name = $0;
61             $prog_name =~ s{^.*[\\/]}{}g;
62             $prog_name = 'perl' if ($prog_name eq '-e' || $prog_name eq '-');
63              
64             sub new {
65 2     2 1 8 my ($class, %obj) = (@_, impl => 'Flock');
66              
67 2 100       6 if (! defined $obj{path}) {
68 1         4 my ($pid, $tmp_dir, $tmp_file) = ( abs($$) );
69              
70 1 50 33     92 if ($ENV{TEMP} && -d $ENV{TEMP} && -w _) {
    50 33        
    50 33        
      33        
      33        
71 0 0       0 if ($^O =~ /mswin|mingw|msys|cygwin/i) {
72 0         0 $tmp_dir = $ENV{TEMP};
73 0 0       0 $tmp_dir .= ($^O eq 'MSWin32') ? "\\Perl-MCE" : "/Perl-MCE";
74 0 0       0 mkdir $tmp_dir unless (-d $tmp_dir);
75             }
76             else {
77 0         0 $tmp_dir = $ENV{TEMP};
78             }
79             }
80             elsif ($ENV{TMPDIR} && -d $ENV{TMPDIR} && -w _) {
81 0         0 $tmp_dir = $ENV{TMPDIR};
82             }
83             elsif (-d '/tmp' && -w _) {
84 1         4 $tmp_dir = '/tmp';
85             }
86             else {
87 0         0 Carp::croak("No writable dir found for a temp file");
88             }
89              
90 1         4 $id++, $tmp_dir =~ s{[\\/]$}{};
91              
92             # remove tainted'ness from $tmp_dir
93 1 50       5 if ($^O eq 'MSWin32') {
94 0         0 ($tmp_file) = "$tmp_dir\\$prog_name.$pid.$tid.$id" =~ /(.*)/;
95             } else {
96 1         7 ($tmp_file) = "$tmp_dir/$prog_name.$pid.$tid.$id" =~ /(.*)/;
97             }
98              
99 1 50       7 $obj{_init} = $tid ? $$ .'.'. $tid : $$;
100 1         3 $obj{ path} = $tmp_file.'.lock';
101              
102             # test open
103             open my $fh, '+>>:raw:stdio', $obj{path}
104 1 50       260 or Carp::croak("Could not create temp file $obj{path}: $!");
105              
106 1         20 close $fh;
107              
108             # set permission
109 1         25 chmod 0600, $obj{path};
110             }
111             else {
112             # test open
113             open my $fh, '+>>:raw:stdio', $obj{path}
114 1 50       88 or Carp::croak("Could not obtain flock on file $obj{path}: $!");
115              
116 1         17 close $fh;
117             }
118              
119 2         19 return bless(\%obj, $class);
120             }
121              
122             sub lock {
123 0 0   0 1   my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift);
124 0 0         $obj->_open() unless exists $obj->{ $pid };
125              
126             CORE::flock ($obj->{_fh}, LOCK_EX), $obj->{ $pid } = 1
127 0 0         unless $obj->{ $pid };
128              
129 0           return;
130             }
131              
132             sub guard_lock {
133 0     0 1   &lock(@_);
134 0 0         bless([ $tid ? $$ .'.'. $tid : $$, $_[0] ], Mutex::Flock::_guard::);
135             }
136              
137             *lock_exclusive = \&lock;
138              
139             sub lock_shared {
140 0 0   0 1   my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift);
141 0 0         $obj->_open() unless exists $obj->{ $pid };
142              
143             CORE::flock ($obj->{_fh}, LOCK_SH), $obj->{ $pid } = 1
144 0 0         unless $obj->{ $pid };
145              
146 0           return;
147             }
148              
149             sub unlock {
150 0 0   0 1   my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift);
151              
152             CORE::flock ($obj->{_fh}, LOCK_UN), $obj->{ $pid } = 0
153 0 0         if $obj->{ $pid };
154              
155 0           return;
156             }
157              
158             sub synchronize {
159 0 0   0 1   my ($pid, $obj, $code) = ($tid ? $$ .'.'. $tid : $$, shift, shift);
160 0           my (@ret);
161              
162 0 0         return unless ref($code) eq 'CODE';
163              
164 0 0         $obj->_open() unless exists $obj->{ $pid };
165              
166             # lock, run, unlock - inlined for performance
167 0           my $guard = bless([ $pid, $obj ], Mutex::Flock::_guard::);
168 0 0         unless ($obj->{ $pid }) {
169 0           CORE::flock ($obj->{_fh}, LOCK_EX), $obj->{ $pid } = 1;
170             }
171             (defined wantarray)
172 0 0         ? @ret = wantarray ? $code->(@_) : scalar $code->(@_)
    0          
173             : $code->(@_);
174              
175 0 0         return wantarray ? @ret : $ret[-1];
176             }
177              
178             *enter = \&synchronize;
179              
180             sub timedwait {
181 0     0 1   my ($obj, $timeout) = @_;
182 0 0         die 'Mutex::Flock::timedwait() unimplemented in this platform'
183             if ($^O eq 'MSWin32');
184              
185 0 0         $timeout = 1 unless defined $timeout;
186 0 0 0       Carp::croak('Mutex::Flock: timedwait (timeout) is not valid')
187             if (!looks_like_number($timeout) || $timeout < 0);
188              
189 0 0         $timeout = 0.0003 if $timeout < 0.0003;
190              
191 0     0     local $@; local $SIG{ALRM} = sub { alarm 0; die "timed out\n" };
  0            
  0            
  0            
192 0           eval { alarm $timeout; $obj->lock_exclusive };
  0            
  0            
193 0           alarm 0;
194              
195 0 0 0       ( $@ && $@ eq "timed out\n" ) ? '' : 1;
196             }
197              
198             1;
199              
200             __END__