← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:09 2021

Filename/usr/local/lib/perl5/site_perl/File/NFSLock.pm
StatementsExecuted 76198 statements in 417ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
359851114ms114msFile::NFSLock::::CORE:unlinkFile::NFSLock::CORE:unlink (opcode)
12043261.4ms333msFile::NFSLock::::newFile::NFSLock::new (recurses: max depth 1, inclusive time 2.57ms)
24083148.0ms48.0msFile::NFSLock::::CORE:linkFile::NFSLock::CORE:link (opcode)
12172147.8ms47.8msFile::NFSLock::::CORE:openFile::NFSLock::CORE:open (opcode)
35993133.2ms33.2msFile::NFSLock::::CORE:ftisFile::NFSLock::CORE:ftis (opcode)
12042121.0ms21.0msFile::NFSLock::::CORE:chmodFile::NFSLock::CORE:chmod (opcode)
12172118.7ms18.7msFile::NFSLock::::CORE:closeFile::NFSLock::CORE:close (opcode)
12041115.2ms83.4msFile::NFSLock::::create_magicFile::NFSLock::create_magic
11911114.4ms93.0msFile::NFSLock::::do_lockFile::NFSLock::do_lock
12041113.7ms72.8msFile::NFSLock::::uncacheFile::NFSLock::uncache
12322212.7ms97.0msFile::NFSLock::::unlockFile::NFSLock::unlock (recurses: max depth 1, inclusive time 730µs)
1191118.89ms65.2msFile::NFSLock::::do_unlockFile::NFSLock::do_unlock
1204422.97ms94.1msFile::NFSLock::::DESTROYFile::NFSLock::DESTROY
2408212.46ms2.46msFile::NFSLock::::CORE:matchFile::NFSLock::CORE:match (opcode)
1204111.93ms1.93msFile::NFSLock::::CORE:printFile::NFSLock::CORE:print (opcode)
119111971µs971µsFile::NFSLock::::CORE:statFile::NFSLock::CORE:stat (opcode)
1311325µs5.34msFile::NFSLock::::do_unlock_sharedFile::NFSLock::do_unlock_shared
1311266µs4.51msFile::NFSLock::::do_lock_sharedFile::NFSLock::do_lock_shared
261191µs91µsFile::NFSLock::::CORE:readlineFile::NFSLock::CORE:readline (opcode)
0000s0sFile::NFSLock::::BEGIN@27File::NFSLock::BEGIN@27
0000s0sFile::NFSLock::::BEGIN@28File::NFSLock::BEGIN@28
0000s0sFile::NFSLock::::BEGIN@30File::NFSLock::BEGIN@30
0000s0sFile::NFSLock::::BEGIN@32File::NFSLock::BEGIN@32
0000s0sFile::NFSLock::::BEGIN@39File::NFSLock::BEGIN@39
0000s0sFile::NFSLock::::__ANON__[:67]File::NFSLock::__ANON__[:67]
0000s0sFile::NFSLock::::forkFile::NFSLock::fork
0000s0sFile::NFSLock::::newpidFile::NFSLock::newpid
0000s0sFile::NFSLock::::rand_fileFile::NFSLock::rand_file
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1# -*- perl -*-
2#
3# File::NFSLock - bdpO - NFS compatible (safe) locking utility
4#
5# $Id: NFSLock.pm,v 1.29 2018/11/01 14:00:00 bbb Exp $
6#
7# Copyright (C) 2002, Paul T Seamons
8# paul@seamons.com
9# http://seamons.com/
10#
11# Rob B Brown
12# bbb@cpan.org
13#
14# This package may be distributed under the terms of either the
15# GNU General Public License
16# or the
17# Perl Artistic License
18#
19# All rights reserved.
20#
21# Please read the perldoc File::NFSLock
22#
23################################################################
24
25package File::NFSLock;
26
27use strict;
28use warnings;
29
30use Carp qw(croak confess);
31our $errstr;
32use base 'Exporter';
33our @EXPORT_OK = qw(uncache);
34
35our $VERSION = '1.29';
36
37#Get constants, but without the bloat of
38#use Fcntl qw(LOCK_SH LOCK_EX LOCK_NB);
39use constant {
40 LOCK_SH => 1,
41 LOCK_EX => 2,
42 LOCK_NB => 4,
43};
44
45### Convert lock_type to a number
46our $TYPES = {
47 BLOCKING => LOCK_EX,
48 BL => LOCK_EX,
49 EXCLUSIVE => LOCK_EX,
50 EX => LOCK_EX,
51 NONBLOCKING => LOCK_EX | LOCK_NB,
52 NB => LOCK_EX | LOCK_NB,
53 SHARED => LOCK_SH,
54 SH => LOCK_SH,
55};
56our $LOCK_EXTENSION = '.NFSLock'; # customizable extension
57our $HOSTNAME = undef;
58our $SHARE_BIT = 1;
59
60###----------------------------------------------------------------###
61
62my $graceful_sig = sub {
63 print STDERR "Received SIG$_[0]\n" if @_;
64 # Perl's exit should safely DESTROY any objects
65 # still "alive" before calling the real _exit().
66 exit 1;
67};
68
69our @CATCH_SIGS = qw(TERM INT);
70
71
# spent 333ms (61.4+272) within File::NFSLock::new which was called 1204 times, avg 277µs/call: # 1178 times (60.7ms+269ms) by Sympa::LockedFile::open at line 77 of /usr/local/libexec/sympa/Sympa/LockedFile.pm, avg 280µs/call # 13 times (415µs+3.07ms) by File::NFSLock::do_unlock_shared at line 394, avg 268µs/call # 13 times (343µs+-343µs) by File::NFSLock::do_lock_shared at line 350, avg 0s/call
sub new {
721204405µs $errstr = undef;
73
741204342µs my $type = shift;
751204430µs my $class = ref($type) || $type || __PACKAGE__;
761204508µs my $self = {};
77
78 ### allow for arguments by hash ref or serially
791204990µs if( @_ && ref $_[0] ){
80 $self = shift;
81 }else{
82139µs $self->{file} = shift;
83137µs $self->{lock_type} = shift;
84135µs $self->{blocking_timeout} = shift;
85135µs $self->{stale_lock_timeout} = shift;
86 }
871204508µs $self->{file} ||= "";
881204294µs $self->{lock_type} ||= 0;
891204269µs $self->{blocking_timeout} ||= 0;
901204259µs $self->{stale_lock_timeout} ||= 0;
9112041.43ms $self->{lock_pid} = $$;
9212041.15ms $self->{unlocked} = 1;
931204624µs foreach my $signal (@CATCH_SIGS) {
9424082.97ms if (!$SIG{$signal} ||
95 $SIG{$signal} eq "DEFAULT") {
96 $SIG{$signal} = $graceful_sig;
97 }
98 }
99
100 ### force lock_type to be numerical
10112049.39ms12041.65ms if( $self->{lock_type} &&
# spent 1.65ms making 1204 calls to File::NFSLock::CORE:match, avg 1µs/call
102 $self->{lock_type} !~ /^\d+/ &&
103 exists $TYPES->{$self->{lock_type}} ){
104 $self->{lock_type} = $TYPES->{$self->{lock_type}};
105 }
106
107 ### need the hostname
1081204372µs if( !$HOSTNAME ){
10913µs require Sys::Hostname;
110114µs154µs $HOSTNAME = Sys::Hostname::hostname();
# spent 54µs making 1 call to Sys::Hostname::hostname
111 }
112
113 ### quick usage check
114 croak ($errstr = "Usage: my \$f = $class->new('/pathtofile/file',\n"
115 ."'BLOCKING|EXCLUSIVE|NONBLOCKING|SHARED', [blocking_timeout, stale_lock_timeout]);\n"
116 ."(You passed \"$self->{file}\" and \"$self->{lock_type}\")")
1171204432µs unless length($self->{file});
118
119 croak ($errstr = "Unrecognized lock_type operation setting [$self->{lock_type}]")
12012042.72ms1204808µs unless $self->{lock_type} && $self->{lock_type} =~ /^\d+$/;
# spent 808µs making 1204 calls to File::NFSLock::CORE:match, avg 671ns/call
121
122 ### Input syntax checking passed, ready to bless
1231204430µs bless $self, $class;
124
125 ### choose a random filename
12612042.35ms12046.32ms $self->{rand_file} = rand_file( $self->{file} );
# spent 6.32ms making 1204 calls to Sympa::LockedFile::__ANON__[/usr/local/libexec/sympa/Sympa/LockedFile.pm:49], avg 5µs/call
127
128 ### choose the lock filename
12912041.04ms $self->{lock_file} = $self->{file} . $LOCK_EXTENSION;
130
131 my $quit_time = $self->{blocking_timeout} &&
132 !($self->{lock_type} & LOCK_NB) ?
1331204851µs time() + $self->{blocking_timeout} : 0;
134
135 ### remove an old lockfile if it is older than the stale_timeout
136120413.7ms120411.7ms if( -e $self->{lock_file} &&
# spent 11.7ms making 1204 calls to File::NFSLock::CORE:ftis, avg 10µs/call
137 $self->{stale_lock_timeout} > 0 &&
138 time() - (stat _)[9] > $self->{stale_lock_timeout} ){
139 unlink $self->{lock_file};
140 }
141
1421204230µs while (1) {
143 ### open the temporary file
14412041.89ms120483.4ms $self->create_magic
# spent 83.4ms making 1204 calls to File::NFSLock::create_magic, avg 69µs/call
145 or return undef;
146
1471204663µs if ( $self->{lock_type} & LOCK_EX ) {
14811912.39ms119193.0ms last if $self->do_lock;
# spent 93.0ms making 1191 calls to File::NFSLock::do_lock, avg 78µs/call
149 } elsif ( $self->{lock_type} & LOCK_SH ) {
1501330µs134.51ms last if $self->do_lock_shared;
# spent 4.51ms making 13 calls to File::NFSLock::do_lock_shared, avg 347µs/call
151 } else {
152 $errstr = "Unknown lock_type [$self->{lock_type}]";
153 return undef;
154 }
155
156 ### Lock failed!
157
158 ### I know this may be a race condition, but it's okay. It is just a
159 ### stab in the dark to possibly find long dead processes.
160
161 ### If lock exists and is readable, see who is mooching on the lock
162
163 my $fh;
164 if ( -e $self->{lock_file} &&
165 open ($fh,'+<', $self->{lock_file}) ){
166
167 my @mine = ();
168 my @them = ();
169 my @dead = ();
170
171 my $has_lock_exclusive = !((stat _)[2] & $SHARE_BIT);
172 my $try_lock_exclusive = !($self->{lock_type} & LOCK_SH);
173
174 while(defined(my $line=<$fh>)){
175 if ($line =~ /^\Q$HOSTNAME\E (-?\d+) /) {
176 my $pid = $1;
177 if ($pid == $$) { # This is me.
178 push @mine, $line;
179 }elsif(kill 0, $pid) { # Still running on this host.
180 push @them, $line;
181 }else{ # Finished running on this host.
182 push @dead, $line;
183 }
184 } else { # Running on another host, so
185 push @them, $line; # assume it is still running.
186 }
187 }
188
189 ### If there was at least one stale lock discovered...
190 if (@dead) {
191 # Lock lock_file to avoid a race condition.
192 local $LOCK_EXTENSION = ".shared";
193 my $lock = new File::NFSLock {
194 file => $self->{lock_file},
195 lock_type => LOCK_EX,
196 blocking_timeout => 62,
197 stale_lock_timeout => 60,
198 };
199
200 ### Rescan in case lock contents were modified between time stale lock
201 ### was discovered and lockfile lock was acquired.
202 seek ($fh, 0, 0);
203 my $content = '';
204 while(defined(my $line=<$fh>)){
205 if ($line =~ /^\Q$HOSTNAME\E (-?\d+) /) {
206 my $pid = $1;
207 next if (!kill 0, $pid); # Skip dead locks from this host
208 }
209 $content .= $line; # Save valid locks
210 }
211
212 ### Save any valid locks or wipe file.
213 if( length($content) ){
214 seek $fh, 0, 0;
215 print $fh $content;
216 truncate $fh, length($content);
217 close $fh;
218 }else{
219 close $fh;
220 unlink $self->{lock_file};
221 }
222
223 ### No "dead" or stale locks found.
224 } else {
225 close $fh;
226 }
227
228 ### If attempting to acquire the same type of lock
229 ### that it is already locked with, and I've already
230 ### locked it myself, then it is safe to lock again.
231 ### Just kick out successfully without really locking.
232 ### Assumes locks will be released in the reverse
233 ### order from how they were established.
234 if ($try_lock_exclusive eq $has_lock_exclusive && @mine){
235 return $self;
236 }
237 }
238
239 ### If non-blocking, then kick out now.
240 ### ($errstr might already be set to the reason.)
241 if ($self->{lock_type} & LOCK_NB) {
242 $errstr ||= "NONBLOCKING lock failed!";
243 return undef;
244 }
245
246 ### wait a moment
247 sleep(1);
248
249 ### but don't wait past the time out
250 if( $quit_time && (time > $quit_time) ){
251 $errstr = "Timed out waiting for blocking lock";
252 return undef;
253 }
254
255 # BLOCKING Lock, So Keep Trying
256 }
257
258 ### clear up the NFS cache
25912041.56ms120472.8ms $self->uncache;
# spent 72.8ms making 1204 calls to File::NFSLock::uncache, avg 60µs/call
260
261 ### Yes, the lock has been acquired.
2621204685µs delete $self->{unlocked};
263
26412047.96ms return $self;
265}
266
267
# spent 94.1ms (2.97+91.2) within File::NFSLock::DESTROY which was called 1204 times, avg 78µs/call: # 1150 times (2.82ms+89.6ms) by Sympa::LockedFile::DESTROY at line 192 of /usr/local/libexec/sympa/Sympa/LockedFile.pm, avg 80µs/call # 28 times (63µs+24µs) by Sympa::LockedFile::close at line 114 of /usr/local/libexec/sympa/Sympa/LockedFile.pm, avg 3µs/call # 13 times (41µs+795µs) by File::NFSLock::do_lock_shared at line 379, avg 64µs/call # 13 times (40µs+730µs) by File::NFSLock::do_unlock_shared at line 414, avg 59µs/call
sub DESTROY {
26812048.42ms120490.4ms shift()->unlock();
# spent 91.2ms making 1204 calls to File::NFSLock::unlock, avg 76µs/call, recursion: max depth 1, sum of overlapping time 730µs
269}
270
271
# spent 97.0ms (12.7+84.4) within File::NFSLock::unlock which was called 1232 times, avg 79µs/call: # 1204 times (12.4ms+78.0ms) by File::NFSLock::DESTROY at line 268, avg 75µs/call # 28 times (303µs+6.31ms) by Sympa::LockedFile::close at line 113 of /usr/local/libexec/sympa/Sympa/LockedFile.pm, avg 236µs/call
sub unlock ($) {
2721232274µs my $self = shift;
2731232698µs if (!$self->{unlocked}) {
274120416.8ms120414.6ms unlink( $self->{rand_file} ) if -e $self->{rand_file};
# spent 14.6ms making 1204 calls to File::NFSLock::CORE:ftis, avg 12µs/call
2751204720µs135.34ms if( $self->{lock_type} & LOCK_SH ){
# spent 5.34ms making 13 calls to File::NFSLock::do_unlock_shared, avg 411µs/call
276 $self->do_unlock_shared;
277 }else{
27811911.49ms119165.2ms $self->do_unlock;
# spent 65.2ms making 1191 calls to File::NFSLock::do_unlock, avg 55µs/call
279 }
2801204735µs $self->{unlocked} = 1;
2811204880µs foreach my $signal (@CATCH_SIGS) {
28224083.73ms if ($SIG{$signal} &&
283 ($SIG{$signal} eq $graceful_sig)) {
284 # Revert handler back to how it used to be.
285 # Unfortunately, this will restore the
286 # handler back even if there are other
287 # locks still in tact, but for most cases,
288 # it will still be an improvement.
289 delete $SIG{$signal};
290 }
291 }
292 }
29312322.00ms return 1;
294}
295
296###----------------------------------------------------------------###
297
298# concepts for these routines were taken from Mail::Box which
299# took the concepts from Mail::Folder
300
301
302sub rand_file ($) {
303 my $file = shift;
304 "$file.tmp.". time()%10000 .'.'. $$ .'.'. int(rand()*10000);
305}
306
307
# spent 83.4ms (15.2+68.2) within File::NFSLock::create_magic which was called 1204 times, avg 69µs/call: # 1204 times (15.2ms+68.2ms) by File::NFSLock::new at line 144, avg 69µs/call
sub create_magic ($;$) {
3081204299µs $errstr = undef;
3091204341µs my $self = shift;
3101204648µs my $append_file = shift || $self->{rand_file};
31112042.51ms $self->{lock_line} ||= "$HOSTNAME $self->{lock_pid} ".time()." ".int(rand()*10000)."\n";
312120451.9ms120447.6ms open (my $fh,'>>', $append_file) or do { $errstr = "Couldn't open \"$append_file\" [$!]"; return undef; };
# spent 47.6ms making 1204 calls to File::NFSLock::CORE:open, avg 40µs/call
31312044.18ms12041.93ms print $fh $self->{lock_line};
# spent 1.93ms making 1204 calls to File::NFSLock::CORE:print, avg 2µs/call
314120420.8ms120418.6ms close $fh;
# spent 18.6ms making 1204 calls to File::NFSLock::CORE:close, avg 15µs/call
31512043.47ms return 1;
316}
317
318
# spent 93.0ms (14.4+78.6) within File::NFSLock::do_lock which was called 1191 times, avg 78µs/call: # 1191 times (14.4ms+78.6ms) by File::NFSLock::new at line 148, avg 78µs/call
sub do_lock {
3191191327µs $errstr = undef;
3201191392µs my $self = shift;
3211191555µs my $lock_file = $self->{lock_file};
3221191360µs my $rand_file = $self->{rand_file};
3231191300µs my $chmod = 0600;
324119123.0ms119120.8ms chmod( $chmod, $rand_file)
# spent 20.8ms making 1191 calls to File::NFSLock::CORE:chmod, avg 17µs/call
325 || die "I need ability to chmod files to adequatetly perform locking";
326
327 ### try a hard link, if it worked
328 ### two files are pointing to $rand_file
329119136.9ms357330.9ms my $success = link( $rand_file, $lock_file )
# spent 23.0ms making 1191 calls to File::NFSLock::CORE:link, avg 19µs/call # spent 6.94ms making 1191 calls to File::NFSLock::CORE:ftis, avg 6µs/call # spent 971µs making 1191 calls to File::NFSLock::CORE:stat, avg 816ns/call
330 && -e $rand_file && (stat _)[3] == 2;
331119129.0ms119126.9ms unlink $rand_file;
# spent 26.9ms making 1191 calls to File::NFSLock::CORE:unlink, avg 23µs/call
332
33311917.75ms return $success;
334}
335
336
# spent 4.51ms (266µs+4.24) within File::NFSLock::do_lock_shared which was called 13 times, avg 347µs/call: # 13 times (266µs+4.24ms) by File::NFSLock::new at line 150, avg 347µs/call
sub do_lock_shared {
337136µs $errstr = undef;
338136µs my $self = shift;
339139µs my $lock_file = $self->{lock_file};
340135µs my $rand_file = $self->{rand_file};
341
342 ### chmod local file to make sure we know before
343134µs my $chmod = 0600;
344136µs $chmod |= $SHARE_BIT;
34513308µs13282µs chmod( $chmod, $rand_file)
# spent 282µs making 13 calls to File::NFSLock::CORE:chmod, avg 22µs/call
346 || die "I need ability to chmod files to adequatetly perform locking";
347
348 ### lock the locking process
3491310µs local $LOCK_EXTENSION = ".shared";
3501366µs130s my $lock = new File::NFSLock {
# spent 2.57ms making 13 calls to File::NFSLock::new, avg 198µs/call, recursion: max depth 1, sum of overlapping time 2.57ms
351 file => $lock_file,
352 lock_type => LOCK_EX,
353 blocking_timeout => 62,
354 stale_lock_timeout => 60,
355 };
356 # The ".shared" lock will be released as this status
357 # is returned, whether or not the status is successful.
358
359 ### If I didn't have exclusive and the shared bit is not
360 ### set, I have failed
361
362 ### Try to create $lock_file from the special
363 ### file with the magic $SHARE_BIT set.
36413273µs13254µs my $success = link( $rand_file, $lock_file);
# spent 254µs making 13 calls to File::NFSLock::CORE:link, avg 20µs/call
36513317µs13299µs unlink $rand_file;
# spent 299µs making 13 calls to File::NFSLock::CORE:unlink, avg 23µs/call
366138µs if ( !$success &&
367 -e $lock_file &&
368 ((stat _)[2] & $SHARE_BIT) != $SHARE_BIT ){
369
370 $errstr = 'Exclusive lock exists.';
371 return undef;
372
373 } elsif ( !$success ) {
374 ### Shared lock exists, append my lock
375 $self->create_magic ($self->{lock_file});
376 }
377
378 # Success
3791377µs13836µs return 1;
# spent 836µs making 13 calls to File::NFSLock::DESTROY, avg 64µs/call
380}
381
382
# spent 65.2ms (8.89+56.3) within File::NFSLock::do_unlock which was called 1191 times, avg 55µs/call: # 1191 times (8.89ms+56.3ms) by File::NFSLock::unlock at line 278, avg 55µs/call
sub do_unlock ($) {
383119166.0ms119156.3ms return unlink shift->{lock_file};
# spent 56.3ms making 1191 calls to File::NFSLock::CORE:unlink, avg 47µs/call
384}
385
386
# spent 5.34ms (325µs+5.01) within File::NFSLock::do_unlock_shared which was called 13 times, avg 411µs/call: # 13 times (325µs+5.01ms) by File::NFSLock::unlock at line 275, avg 411µs/call
sub do_unlock_shared ($) {
387137µs $errstr = undef;
388134µs my $self = shift;
3891310µs my $lock_file = $self->{lock_file};
390136µs my $lock_line = $self->{lock_line};
391
392 ### lock the locking process
393138µs local $LOCK_EXTENSION = '.shared';
3941349µs133.48ms my $lock = new File::NFSLock ($lock_file,LOCK_EX,62,60);
# spent 3.48ms making 13 calls to File::NFSLock::new, avg 268µs/call
395
396 ### get the handle on the lock file
397133µs my $fh;
39813207µs13170µs if( ! open ($fh,'+<', $lock_file) ){
# spent 170µs making 13 calls to File::NFSLock::CORE:open, avg 13µs/call
399 if( ! -e $lock_file ){
400 return 1;
401 }else{
402 die "Could not open for writing shared lock file $lock_file ($!)";
403 }
404 }
405
406 ### read existing file
407135µs my $content = '';
40813138µs2691µs while(defined(my $line=<$fh>)){
# spent 91µs making 26 calls to File::NFSLock::CORE:readline, avg 3µs/call
4091311µs next if $line eq $lock_line;
410 $content .= $line;
411 }
412
413 ### other shared locks exist
4141391µs13770µs if( length($content) ){
# spent 770µs making 13 calls to File::NFSLock::DESTROY, avg 59µs/call
415 seek $fh, 0, 0;
416 print $fh $content;
417 truncate $fh, length($content);
418 close $fh;
419
420 ### only I exist
421 }else{
4221339µs1323µs close $fh;
# spent 23µs making 13 calls to File::NFSLock::CORE:close, avg 2µs/call
42313495µs13475µs unlink $lock_file;
# spent 475µs making 13 calls to File::NFSLock::CORE:unlink, avg 37µs/call
424 }
425
426}
427
428
# spent 72.8ms (13.7+59.1) within File::NFSLock::uncache which was called 1204 times, avg 60µs/call: # 1204 times (13.7ms+59.1ms) by File::NFSLock::new at line 259, avg 60µs/call
sub uncache ($;$) {
429 # allow as method call
4301204538µs my $file = pop;
4311204924µs ref $file && ($file = $file->{file});
43212041.46ms12044.61ms my $rand_file = rand_file( $file );
# spent 4.61ms making 1204 calls to Sympa::LockedFile::__ANON__[/usr/local/libexec/sympa/Sympa/LockedFile.pm:49], avg 4µs/call
433
434 ### hard link to the actual file which will bring it up to date
435120470.8ms239454.5ms return ( link( $file, $rand_file) && unlink($rand_file) );
# spent 29.6ms making 1190 calls to File::NFSLock::CORE:unlink, avg 25µs/call # spent 24.8ms making 1204 calls to File::NFSLock::CORE:link, avg 21µs/call
436}
437
438sub newpid {
439 my $self = shift;
440 # Detect if this is the parent or the child
441 if ($self->{lock_pid} == $$) {
442 # This is the parent
443
444 # Must wait for child to call newpid before processing.
445 # A little patience for the child to call newpid
446 my $patience = time + 10;
447 while (time < $patience) {
448 if (rename("$self->{lock_file}.fork",$self->{rand_file})) {
449 # Child finished its newpid call.
450 # Wipe the signal file.
451 unlink $self->{rand_file};
452 last;
453 }
454 # Brief pause before checking again
455 # to avoid intensive IO across NFS.
456 select(undef,undef,undef,0.1);
457 }
458
459 # Child finished running newpid() and acquired shared lock
460 # So now we're safe to continue without risk of
461 # blowing away the lock prematurely.
462 unless ( $self->{lock_type} & LOCK_SH ) {
463 # If it's not already a SHared lock, then
464 # just switch it from EXclusive to SHared
465 # from this process's point of view.
466 # Then the child will still hold the lock
467 # if the parent releases it first.
468 # (Don't chmod the lock file.)
469 $self->{lock_type} |= LOCK_SH;
470 }
471 } else {
472 # This is the new child
473
474 # Fix lock_pid to the new pid.
475 $self->{lock_pid} = $$;
476
477 # We can leave the old lock_line in the lock_file
478 # But we need to add the new lock_line for this pid.
479
480 # Clear lock_line to create a fresh one.
481 delete $self->{lock_line};
482 # Append a new lock_line to the lock_file.
483 $self->create_magic($self->{lock_file});
484
485 unless ( $self->{lock_type} & LOCK_SH ) {
486 # If it's not already a SHared lock, then
487 # just switch it from EXclusive to SHared
488 # from this process's point of view.
489 # Then the parent will still hold the lock
490 # if this child releases it first.
491 # (Don't chmod the lock file.)
492 $self->{lock_type} |= LOCK_SH;
493 }
494
495 # Create signal file to notify parent that
496 # the lock_line entry has been delegated.
497 open (my $fh, '>', "$self->{lock_file}.fork");
498 close($fh);
499 }
500}
501
502sub fork {
503 my $self = shift;
504 # Store fork response.
505 my $pid = CORE::fork();
506 if (defined $pid and !$self->{unlocked}) {
507 # Fork worked and we really have a lock to deal with
508 # So upgrade to shared lock across both parent and child
509 $self->newpid;
510 }
511 # Return original fork response
512 return $pid;
513}
514
5151;
516
517
518=pod
519
520=head1 NAME
521
522File::NFSLock - perl module to do NFS (or not) locking
523
524=head1 SYNOPSIS
525
526 use File::NFSLock qw(uncache);
527 use Fcntl qw(LOCK_EX LOCK_NB);
528
529 my $file = "somefile";
530
531 ### set up a lock - lasts until object looses scope
532 if (my $lock = new File::NFSLock {
533 file => $file,
534 lock_type => LOCK_EX|LOCK_NB,
535 blocking_timeout => 10, # 10 sec
536 stale_lock_timeout => 30 * 60, # 30 min
537 }) {
538
539 ### OR
540 ### my $lock = File::NFSLock->new($file,LOCK_EX|LOCK_NB,10,30*60);
541
542 ### do write protected stuff on $file
543 ### at this point $file is uncached from NFS (most recent)
544 open(FILE, "+<$file") || die $!;
545
546 ### or open it any way you like
547 ### my $fh = IO::File->open( $file, 'w' ) || die $!
548
549 ### update (uncache across NFS) other files
550 uncache("someotherfile1");
551 uncache("someotherfile2");
552 # open(FILE2,"someotherfile1");
553
554 ### unlock it
555 $lock->unlock();
556 ### OR
557 ### undef $lock;
558 ### OR let $lock go out of scope
559 }else{
560 die "I couldn't lock the file [$File::NFSLock::errstr]";
561 }
562
563
564=head1 DESCRIPTION
565
566Program based of concept of hard linking of files being atomic across
567NFS. This concept was mentioned in Mail::Box::Locker (which was
568originally presented in Mail::Folder::Maildir). Some routine flow is
569taken from there -- particularly the idea of creating a random local
570file, hard linking a common file to the local file, and then checking
571the nlink status. Some ideologies were not complete (uncache
572mechanism, shared locking) and some coding was even incorrect (wrong
573stat index). File::NFSLock was written to be light, generic,
574and fast.
575
576
577=head1 USAGE
578
579Locking occurs by creating a File::NFSLock object. If the object
580is created successfully, a lock is currently in place and remains in
581place until the lock object goes out of scope (or calls the unlock
582method).
583
584A lock object is created by calling the new method and passing two
585to four parameters in the following manner:
586
587 my $lock = File::NFSLock->new($file,
588 $lock_type,
589 $blocking_timeout,
590 $stale_lock_timeout,
591 );
592
593Additionally, parameters may be passed as a hashref:
594
595 my $lock = File::NFSLock->new({
596 file => $file,
597 lock_type => $lock_type,
598 blocking_timeout => $blocking_timeout,
599 stale_lock_timeout => $stale_lock_timeout,
600 });
601
602=head1 PARAMETERS
603
604=over 4
605
606=item Parameter 1: file
607
608Filename of the file upon which it is anticipated that a write will
609happen to. Locking will provide the most recent version (uncached)
610of this file upon a successful file lock. It is not necessary
611for this file to exist.
612
613=item Parameter 2: lock_type
614
615Lock type must be one of the following:
616
617 BLOCKING
618 BL
619 EXCLUSIVE (BLOCKING)
620 EX
621 NONBLOCKING
622 NB
623 SHARED
624 SH
625
626Or else one or more of the following joined with '|':
627
628 Fcntl::LOCK_EX() (BLOCKING)
629 Fcntl::LOCK_NB() (NONBLOCKING)
630 Fcntl::LOCK_SH() (SHARED)
631
632Lock type determines whether the lock will be blocking, non blocking,
633or shared. Blocking locks will wait until other locks are removed
634before the process continues. Non blocking locks will return undef if
635another process currently has the lock. Shared will allow other
636process to do a shared lock at the same time as long as there is not
637already an exclusive lock obtained.
638
639=item Parameter 3: blocking_timeout (optional)
640
641Timeout is used in conjunction with a blocking timeout. If specified,
642File::NFSLock will block up to the number of seconds specified in
643timeout before returning undef (could not get a lock).
644
645
646=item Parameter 4: stale_lock_timeout (optional)
647
648Timeout is used to see if an existing lock file is older than the stale
649lock timeout. If do_lock fails to get a lock, the modified time is checked
650and do_lock is attempted again. If the stale_lock_timeout is set to low, a
651recursion load could exist so do_lock will only recurse 10 times (this is only
652a problem if the stale_lock_timeout is set too low -- on the order of one or two
653seconds).
654
655=back
656
657=head1 METHODS
658
659After the $lock object is instantiated with new,
660as outlined above, some methods may be used for
661additional functionality.
662
663=head2 unlock
664
665 $lock->unlock;
666
667This method may be used to explicitly release a lock
668that is acquired. In most cases, it is not necessary
669to call unlock directly since it will implicitly be
670called when the object leaves whatever scope it is in.
671
672=head2 uncache
673
674 $lock->uncache;
675 $lock->uncache("otherfile1");
676 uncache("otherfile2");
677
678This method is used to freshen up the contents of a
679file across NFS, ignoring what is contained in the
680NFS client cache. It is always called from within
681the new constructor on the file that the lock is
682being attempted. uncache may be used as either an
683object method or as a stand alone subroutine.
684
685=head2 fork
686
687 my $pid = $lock->fork;
688 if (!defined $pid) {
689 # Fork Failed
690 } elsif ($pid) {
691 # Parent ...
692 } else {
693 # Child ...
694 }
695
696fork() is a convenience method that acts just like the normal
697CORE::fork() except it safely ensures the lock is retained
698within both parent and child processes. WITHOUT this, then when
699either the parent or child process releases the lock, then the
700entire lock will be lost, allowing external processes to
701re-acquire a lock on the same file, even if the other process
702still has the lock object in scope. This can cause corruption
703since both processes might think they have exclusive access to
704the file.
705
706=head2 newpid
707
708 my $pid = fork;
709 if (!defined $pid) {
710 # Fork Failed
711 } elsif ($pid) {
712 $lock->newpid;
713 # Parent ...
714 } else {
715 $lock->newpid;
716 # Child ...
717 }
718
719The newpid() synopsis shown above is equivalent to the
720one used for the fork() method, but it's not intended
721to be called directly. It is called internally by the
722fork() method. To be safe, it is recommended to use
723$lock->fork() from now on.
724
725=head1 FAILURE
726
727On failure, a global variable, $File::NFSLock::errstr, should be set and should
728contain the cause for the failure to get a lock. Useful primarily for debugging.
729
730=head1 LOCK_EXTENSION
731
732By default File::NFSLock will use a lock file extension of ".NFSLock". This is
733in a global variable $File::NFSLock::LOCK_EXTENSION that may be changed to
734suit other purposes (such as compatibility in mail systems).
735
736=head1 REPO
737
738The source is now on github:
739
740git clone https://github.com/hookbot/File-NFSLock
741
742=head1 BUGS
743
744If you spot anything, please submit a pull request on
745github and/or submit a ticket with RT:
746https://rt.cpan.org/Dist/Display.html?Queue=File-NFSLock
747
748=head2 FIFO
749
750Locks are not necessarily obtained on a first come first serve basis.
751Not only does this not seem fair to new processes trying to obtain a lock,
752but it may cause a process starvation condition on heavily locked files.
753
754=head2 DIRECTORIES
755
756Locks cannot be obtained on directory nodes, nor can a directory node be
757uncached with the uncache routine because hard links do not work with
758directory nodes. Some other algorithm might be used to uncache a
759directory, but I am unaware of the best way to do it. The biggest use I
760can see would be to avoid NFS cache of directory modified and last accessed
761timestamps.
762
763=head1 INSTALL
764
765Download and extract tarball before running
766these commands in its base directory:
767
768 perl Makefile.PL
769 make
770 make test
771 make install
772
773For RPM installation, download tarball before
774running these commands in your _topdir:
775
776 rpm -ta SOURCES/File-NFSLock-*.tar.gz
777 rpm -ih RPMS/noarch/perl-File-NFSLock-*.rpm
778
779=head1 AUTHORS
780
781Paul T Seamons (paul@seamons.com) - Performed majority of the
782programming with copious amounts of input from Rob Brown.
783
784Rob B Brown (bbb@cpan.org) - In addition to helping in the
785programming, Rob Brown provided most of the core testing to make sure
786implementation worked properly. He is now the current maintainer.
787
788Also Mark Overmeer (mark@overmeer.net) - Author of Mail::Box::Locker,
789from which some key concepts for File::NFSLock were taken.
790
791Also Kevin Johnson (kjj@pobox.com) - Author of Mail::Folder::Maildir,
792from which Mark Overmeer based Mail::Box::Locker.
793
794=head1 COPYRIGHT
795
796 Copyright (C) 2001
797 Paul T Seamons
798 paul@seamons.com
799 http://seamons.com/
800
801 Copyright (C) 2002-2018,
802 Rob B Brown
803 bbb@cpan.org
804
805 This package may be distributed under the terms of either the
806 GNU General Public License
807 or the
808 Perl Artistic License
809
810 All rights reserved.
811
812=cut
 
# spent 21.0ms within File::NFSLock::CORE:chmod which was called 1204 times, avg 17µs/call: # 1191 times (20.8ms+0s) by File::NFSLock::do_lock at line 324, avg 17µs/call # 13 times (282µs+0s) by File::NFSLock::do_lock_shared at line 345, avg 22µs/call
sub File::NFSLock::CORE:chmod; # opcode
# spent 18.7ms within File::NFSLock::CORE:close which was called 1217 times, avg 15µs/call: # 1204 times (18.6ms+0s) by File::NFSLock::create_magic at line 314, avg 15µs/call # 13 times (23µs+0s) by File::NFSLock::do_unlock_shared at line 422, avg 2µs/call
sub File::NFSLock::CORE:close; # opcode
# spent 33.2ms within File::NFSLock::CORE:ftis which was called 3599 times, avg 9µs/call: # 1204 times (14.6ms+0s) by File::NFSLock::unlock at line 274, avg 12µs/call # 1204 times (11.7ms+0s) by File::NFSLock::new at line 136, avg 10µs/call # 1191 times (6.94ms+0s) by File::NFSLock::do_lock at line 329, avg 6µs/call
sub File::NFSLock::CORE:ftis; # opcode
# spent 48.0ms within File::NFSLock::CORE:link which was called 2408 times, avg 20µs/call: # 1204 times (24.8ms+0s) by File::NFSLock::uncache at line 435, avg 21µs/call # 1191 times (23.0ms+0s) by File::NFSLock::do_lock at line 329, avg 19µs/call # 13 times (254µs+0s) by File::NFSLock::do_lock_shared at line 364, avg 20µs/call
sub File::NFSLock::CORE:link; # opcode
# spent 2.46ms within File::NFSLock::CORE:match which was called 2408 times, avg 1µs/call: # 1204 times (1.65ms+0s) by File::NFSLock::new at line 101, avg 1µs/call # 1204 times (808µs+0s) by File::NFSLock::new at line 120, avg 671ns/call
sub File::NFSLock::CORE:match; # opcode
# spent 47.8ms within File::NFSLock::CORE:open which was called 1217 times, avg 39µs/call: # 1204 times (47.6ms+0s) by File::NFSLock::create_magic at line 312, avg 40µs/call # 13 times (170µs+0s) by File::NFSLock::do_unlock_shared at line 398, avg 13µs/call
sub File::NFSLock::CORE:open; # opcode
# spent 1.93ms within File::NFSLock::CORE:print which was called 1204 times, avg 2µs/call: # 1204 times (1.93ms+0s) by File::NFSLock::create_magic at line 313, avg 2µs/call
sub File::NFSLock::CORE:print; # opcode
# spent 91µs within File::NFSLock::CORE:readline which was called 26 times, avg 3µs/call: # 26 times (91µs+0s) by File::NFSLock::do_unlock_shared at line 408, avg 3µs/call
sub File::NFSLock::CORE:readline; # opcode
# spent 971µs within File::NFSLock::CORE:stat which was called 1191 times, avg 816ns/call: # 1191 times (971µs+0s) by File::NFSLock::do_lock at line 329, avg 816ns/call
sub File::NFSLock::CORE:stat; # opcode
# spent 114ms within File::NFSLock::CORE:unlink which was called 3598 times, avg 32µs/call: # 1191 times (56.3ms+0s) by File::NFSLock::do_unlock at line 383, avg 47µs/call # 1191 times (26.9ms+0s) by File::NFSLock::do_lock at line 331, avg 23µs/call # 1190 times (29.6ms+0s) by File::NFSLock::uncache at line 435, avg 25µs/call # 13 times (475µs+0s) by File::NFSLock::do_unlock_shared at line 423, avg 37µs/call # 13 times (299µs+0s) by File::NFSLock::do_lock_shared at line 365, avg 23µs/call
sub File::NFSLock::CORE:unlink; # opcode