File Coverage

blib/lib/MCE/Mutex/Flock.pm
Criterion Covered Total %
statement 41 87 47.1
branch 13 76 17.1
condition 7 24 29.1
subroutine 9 17 52.9
pod 6 6 100.0
total 76 210 36.1


line stmt bran cond sub pod time code
1             ###############################################################################
2             ## ----------------------------------------------------------------------------
3             ## MCE::Mutex::Flock - Mutex locking via Fcntl.
4             ##
5             ###############################################################################
6              
7             package MCE::Mutex::Flock;
8              
9 2     2   901 use strict;
  2         4  
  2         50  
10 2     2   8 use warnings;
  2         3  
  2         52  
11              
12 2     2   7 no warnings qw( threads recursion uninitialized once );
  2         3  
  2         85  
13              
14             our $VERSION = '1.887';
15              
16 2     2   10 use base 'MCE::Mutex';
  2         3  
  2         224  
17 2     2   13 use Fcntl ':flock';
  2         2  
  2         250  
18 2     2   15 use Scalar::Util 'looks_like_number';
  2         3  
  2         97  
19 2     2   10 use Time::HiRes 'alarm';
  2         4  
  2         10  
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 DESTROY {
28 2 50   2   1193 my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, @_);
29              
30 2 50       7 $obj->unlock(), close(delete $obj->{_fh}) if $obj->{ $pid };
31 2 100 66     57 unlink $obj->{path} if ($obj->{_init} && $obj->{_init} eq $pid);
32              
33 2         11 return;
34             }
35              
36             sub _open {
37 0 0   0   0 my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, @_);
38 0 0       0 return if exists $obj->{ $pid };
39              
40             open $obj->{_fh}, '+>>:raw:stdio', $obj->{path}
41 0 0       0 or Carp::croak("Could not create temp file $obj->{path}: $!");
42              
43 0         0 return;
44             }
45              
46             ###############################################################################
47             ## ----------------------------------------------------------------------------
48             ## Public methods.
49             ##
50             ###############################################################################
51              
52             my ($id, $prog_name) = (0);
53              
54             $prog_name = $0;
55             $prog_name =~ s{^.*[\\/]}{}g;
56             $prog_name = 'perl' if ($prog_name eq '-e' || $prog_name eq '-');
57              
58             sub new {
59 2     2 1 7 my ($class, %obj) = (@_, impl => 'Flock');
60              
61 2 100       5 if (! defined $obj{path}) {
62 1         4 my ($pid, $tmp_dir, $tmp_file) = ( abs($$) );
63              
64 1 50 33     30 if ($ENV{TEMP} && -d $ENV{TEMP} && -w _) {
    50 33        
    50 33        
      33        
      33        
65 0 0       0 if ($^O =~ /mswin|mingw|msys|cygwin/i) {
66 0         0 $tmp_dir = $ENV{TEMP};
67 0 0       0 $tmp_dir .= ($^O eq 'MSWin32') ? "\\Perl-MCE" : "/Perl-MCE";
68 0 0       0 mkdir $tmp_dir unless (-d $tmp_dir);
69             }
70             else {
71 0         0 $tmp_dir = $ENV{TEMP};
72             }
73             }
74             elsif ($ENV{TMPDIR} && -d $ENV{TMPDIR} && -w _) {
75 0         0 $tmp_dir = $ENV{TMPDIR};
76             }
77             elsif (-d '/tmp' && -w _) {
78 1         2 $tmp_dir = '/tmp';
79             }
80             else {
81 0         0 Carp::croak("No writable dir found for a temp file");
82             }
83              
84 1         3 $id++, $tmp_dir =~ s{[\\/]$}{};
85              
86             # remove tainted'ness from $tmp_dir
87 1 50       4 if ($^O eq 'MSWin32') {
88 0         0 ($tmp_file) = "$tmp_dir\\$prog_name.$pid.$tid.$id" =~ /(.*)/;
89             } else {
90 1         6 ($tmp_file) = "$tmp_dir/$prog_name.$pid.$tid.$id" =~ /(.*)/;
91             }
92              
93 1 50       6 $obj{_init} = $tid ? $$ .'.'. $tid : $$;
94 1         3 $obj{ path} = $tmp_file.'.lock';
95              
96             # test open
97             open my $fh, '+>>:raw:stdio', $obj{path}
98 1 50       135 or Carp::croak("Could not create temp file $obj{path}: $!");
99              
100 1         16 close $fh;
101              
102             # set permission
103 1         22 chmod 0600, $obj{path};
104             }
105             else {
106             # test open
107             open my $fh, '+>>:raw:stdio', $obj{path}
108 1 50       74 or Carp::croak("Could not obtain flock on file $obj{path}: $!");
109              
110 1         14 close $fh;
111             }
112              
113 2         15 return bless(\%obj, $class);
114             }
115              
116             sub lock {
117 0 0   0 1   my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift);
118 0 0         $obj->_open() unless exists $obj->{ $pid };
119              
120             CORE::flock ($obj->{_fh}, LOCK_EX), $obj->{ $pid } = 1
121 0 0         unless $obj->{ $pid };
122              
123 0           return;
124             }
125              
126             *lock_exclusive = \&lock;
127              
128             sub lock_shared {
129 0 0   0 1   my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift);
130 0 0         $obj->_open() unless exists $obj->{ $pid };
131              
132             CORE::flock ($obj->{_fh}, LOCK_SH), $obj->{ $pid } = 1
133 0 0         unless $obj->{ $pid };
134              
135 0           return;
136             }
137              
138             sub unlock {
139 0 0   0 1   my ($pid, $obj) = ($tid ? $$ .'.'. $tid : $$, shift);
140              
141             CORE::flock ($obj->{_fh}, LOCK_UN), $obj->{ $pid } = 0
142 0 0         if $obj->{ $pid };
143              
144 0           return;
145             }
146              
147             sub synchronize {
148 0 0   0 1   my ($pid, $obj, $code) = ($tid ? $$ .'.'. $tid : $$, shift, shift);
149 0           my (@ret);
150              
151 0 0         return unless ref($code) eq 'CODE';
152              
153 0 0         $obj->_open() unless exists $obj->{ $pid };
154              
155             # lock, run, unlock - inlined for performance
156             CORE::flock ($obj->{_fh}, LOCK_EX), $obj->{ $pid } = 1
157 0 0         unless $obj->{ $pid };
158              
159             (defined wantarray)
160 0 0         ? @ret = wantarray ? $code->(@_) : scalar $code->(@_)
    0          
161             : $code->(@_);
162              
163 0           CORE::flock ($obj->{_fh}, LOCK_UN), $obj->{ $pid } = 0;
164              
165 0 0         return wantarray ? @ret : $ret[-1];
166             }
167              
168             *enter = \&synchronize;
169              
170             sub timedwait {
171 0     0 1   my ($obj, $timeout) = @_;
172 0 0         die 'MCE::Mutex::Flock::timedwait() unimplemented in this platform'
173             if ($^O eq 'MSWin32');
174              
175 0 0         $timeout = 1 unless defined $timeout;
176 0 0 0       Carp::croak('MCE::Mutex: timedwait (timeout) is not valid')
177             if (!looks_like_number($timeout) || $timeout < 0);
178              
179 0 0         $timeout = 0.0003 if $timeout < 0.0003;
180              
181 0     0     local $@; local $SIG{ALRM} = sub { alarm 0; die "timed out\n" };
  0            
  0            
  0            
182 0           eval { alarm $timeout; $obj->lock_exclusive };
  0            
  0            
183 0           alarm 0;
184              
185 0 0 0       ( $@ && $@ eq "timed out\n" ) ? '' : 1;
186             }
187              
188             1;
189              
190             __END__
191              
192             ###############################################################################
193             ## ----------------------------------------------------------------------------
194             ## Module usage.
195             ##
196             ###############################################################################
197              
198             =head1 NAME
199              
200             MCE::Mutex::Flock - Mutex locking via Fcntl
201              
202             =head1 VERSION
203              
204             This document describes MCE::Mutex::Flock version 1.887
205              
206             =head1 DESCRIPTION
207              
208             A Fcntl implementation for C<MCE::Mutex>.
209              
210             The API is described in L<MCE::Mutex>.
211              
212             =over 3
213              
214             =item new
215              
216             =item lock
217              
218             =item lock_exclusive
219              
220             =item lock_shared
221              
222             =item unlock
223              
224             =item synchronize
225              
226             =item enter
227              
228             =item timedwait
229              
230             =back
231              
232             =head1 AUTHOR
233              
234             Mario E. Roy, S<E<lt>marioeroy AT gmail DOT comE<gt>>
235              
236             =cut
237