1# -*- perl -*- 2# 3# File::NFSLock - bdpO - NFS compatible (safe) locking utility 4# 5# $Id: NFSLock.pm,v 1.34 2003/05/13 18:06:41 hookbot 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 Exporter (); 29use vars qw(@ISA @EXPORT_OK $VERSION $TYPES 30 $LOCK_EXTENSION $SHARE_BIT $HOSTNAME $errstr 31 $graceful_sig @CATCH_SIGS); 32use Carp qw(croak confess); 33 34@ISA = qw(Exporter); 35@EXPORT_OK = qw(uncache); 36 37$VERSION = '1.20'; 38 39#Get constants, but without the bloat of 40#use Fcntl qw(LOCK_SH LOCK_EX LOCK_NB); 41sub LOCK_SH {1} 42sub LOCK_EX {2} 43sub LOCK_NB {4} 44 45### Convert lock_type to a number 46$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}; 56$LOCK_EXTENSION = '.NFSLock'; # customizable extension 57$HOSTNAME = undef; 58$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; 67}; 68 69@CATCH_SIGS = qw(TERM INT); 70 71sub new { 72 $errstr = undef; 73 74 my $type = shift; 75 my $class = ref($type) || $type || __PACKAGE__; 76 my $self = {}; 77 78 ### allow for arguments by hash ref or serially 79 if( @_ && ref $_[0] ){ 80 $self = shift; 81 }else{ 82 $self->{file} = shift; 83 $self->{lock_type} = shift; 84 $self->{blocking_timeout} = shift; 85 $self->{stale_lock_timeout} = shift; 86 } 87 $self->{file} ||= ""; 88 $self->{lock_type} ||= 0; 89 $self->{blocking_timeout} ||= 0; 90 $self->{stale_lock_timeout} ||= 0; 91 $self->{lock_pid} = $$; 92 $self->{unlocked} = 1; 93 foreach my $signal (@CATCH_SIGS) { 94 if (!$SIG{$signal} || 95 $SIG{$signal} eq "DEFAULT") { 96 $SIG{$signal} = $graceful_sig; 97 } 98 } 99 100 ### force lock_type to be numerical 101 if( $self->{lock_type} && 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 108 if( !$HOSTNAME ){ 109 require Sys::Hostname; 110 $HOSTNAME = &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}\")") 117 unless length($self->{file}); 118 119 croak ($errstr = "Unrecognized lock_type operation setting [$self->{lock_type}]") 120 unless $self->{lock_type} && $self->{lock_type} =~ /^\d+$/; 121 122 ### Input syntax checking passed, ready to bless 123 bless $self, $class; 124 125 ### choose a random filename 126 $self->{rand_file} = rand_file( $self->{file} ); 127 128 ### choose the lock filename 129 $self->{lock_file} = $self->{file} . $LOCK_EXTENSION; 130 131 my $quit_time = $self->{blocking_timeout} && 132 !($self->{lock_type} & LOCK_NB) ? 133 time() + $self->{blocking_timeout} : 0; 134 135 ### remove an old lockfile if it is older than the stale_timeout 136 if( -e $self->{lock_file} && 137 $self->{stale_lock_timeout} > 0 && 138 time() - (stat _)[9] > $self->{stale_lock_timeout} ){ 139 unlink $self->{lock_file}; 140 } 141 142 while (1) { 143 ### open the temporary file 144 $self->create_magic 145 or return undef; 146 147 if ( $self->{lock_type} & LOCK_EX ) { 148 last if $self->do_lock; 149 } elsif ( $self->{lock_type} & LOCK_SH ) { 150 last if $self->do_lock_shared; 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 if ( -e $self->{lock_file} && 164 open (_FH,"+<$self->{lock_file}") ){ 165 166 my @mine = (); 167 my @them = (); 168 my @dead = (); 169 170 my $has_lock_exclusive = !((stat _)[2] & $SHARE_BIT); 171 my $try_lock_exclusive = !($self->{lock_type} & LOCK_SH); 172 173 while(defined(my $line=<_FH>)){ 174 if ($line =~ /^$HOSTNAME (\d+) /) { 175 my $pid = $1; 176 if ($pid == $$) { # This is me. 177 push @mine, $line; 178 }elsif(kill 0, $pid) { # Still running on this host. 179 push @them, $line; 180 }else{ # Finished running on this host. 181 push @dead, $line; 182 } 183 } else { # Running on another host, so 184 push @them, $line; # assume it is still running. 185 } 186 } 187 188 ### If there was at least one stale lock discovered... 189 if (@dead) { 190 # Lock lock_file to avoid a race condition. 191 local $LOCK_EXTENSION = ".shared"; 192 my $lock = new File::NFSLock { 193 file => $self->{lock_file}, 194 lock_type => LOCK_EX, 195 blocking_timeout => 62, 196 stale_lock_timeout => 60, 197 }; 198 199 ### Rescan in case lock contents were modified between time stale lock 200 ### was discovered and lockfile lock was acquired. 201 seek (_FH, 0, 0); 202 my $content = ''; 203 while(defined(my $line=<_FH>)){ 204 if ($line =~ /^$HOSTNAME (\d+) /) { 205 my $pid = $1; 206 next if (!kill 0, $pid); # Skip dead locks from this host 207 } 208 $content .= $line; # Save valid locks 209 } 210 211 ### Save any valid locks or wipe file. 212 if( length($content) ){ 213 seek _FH, 0, 0; 214 print _FH $content; 215 truncate _FH, length($content); 216 close _FH; 217 }else{ 218 close _FH; 219 unlink $self->{lock_file}; 220 } 221 222 ### No "dead" or stale locks found. 223 } else { 224 close _FH; 225 } 226 227 ### If attempting to acquire the same type of lock 228 ### that it is already locked with, and I've already 229 ### locked it myself, then it is safe to lock again. 230 ### Just kick out successfully without really locking. 231 ### Assumes locks will be released in the reverse 232 ### order from how they were established. 233 if ($try_lock_exclusive eq $has_lock_exclusive && @mine){ 234 return $self; 235 } 236 } 237 238 ### If non-blocking, then kick out now. 239 ### ($errstr might already be set to the reason.) 240 if ($self->{lock_type} & LOCK_NB) { 241 $errstr ||= "NONBLOCKING lock failed!"; 242 return undef; 243 } 244 245 ### wait a moment 246 sleep(1); 247 248 ### but don't wait past the time out 249 if( $quit_time && (time > $quit_time) ){ 250 $errstr = "Timed out waiting for blocking lock"; 251 return undef; 252 } 253 254 # BLOCKING Lock, So Keep Trying 255 } 256 257 ### clear up the NFS cache 258 $self->uncache; 259 260 ### Yes, the lock has been aquired. 261 delete $self->{unlocked}; 262 263 return $self; 264} 265 266sub DESTROY { 267 shift()->unlock(); 268} 269 270sub unlock ($) { 271 my $self = shift; 272 if (!$self->{unlocked}) { 273 unlink( $self->{rand_file} ) if -e $self->{rand_file}; 274 if( $self->{lock_type} & LOCK_SH ){ 275 return $self->do_unlock_shared; 276 }else{ 277 return $self->do_unlock; 278 } 279 $self->{unlocked} = 1; 280 foreach my $signal (@CATCH_SIGS) { 281 if ($SIG{$signal} && 282 ($SIG{$signal} eq $graceful_sig)) { 283 # Revert handler back to how it used to be. 284 # Unfortunately, this will restore the 285 # handler back even if there are other 286 # locks still in tact, but for most cases, 287 # it will still be an improvement. 288 delete $SIG{$signal}; 289 } 290 } 291 } 292 return 1; 293} 294 295###----------------------------------------------------------------### 296 297# concepts for these routines were taken from Mail::Box which 298# took the concepts from Mail::Folder 299 300 301sub rand_file ($) { 302 my $file = shift; 303 "$file.tmp.". time()%10000 .'.'. $$ .'.'. int(rand()*10000); 304} 305 306sub create_magic ($;$) { 307 $errstr = undef; 308 my $self = shift; 309 my $append_file = shift || $self->{rand_file}; 310 $self->{lock_line} ||= "$HOSTNAME $self->{lock_pid} ".time()." ".int(rand()*10000)."\n"; 311 local *_FH; 312 open (_FH,">>$append_file") or do { $errstr = "Couldn't open \"$append_file\" [$!]"; return undef; }; 313 print _FH $self->{lock_line}; 314 close _FH; 315 return 1; 316} 317 318sub do_lock { 319 $errstr = undef; 320 my $self = shift; 321 my $lock_file = $self->{lock_file}; 322 my $rand_file = $self->{rand_file}; 323 my $chmod = 0600; 324 chmod( $chmod, $rand_file) 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 329 my $success = link( $rand_file, $lock_file ) 330 && -e $rand_file && (stat _)[3] == 2; 331 unlink $rand_file; 332 333 return $success; 334} 335 336sub do_lock_shared { 337 $errstr = undef; 338 my $self = shift; 339 my $lock_file = $self->{lock_file}; 340 my $rand_file = $self->{rand_file}; 341 342 ### chmod local file to make sure we know before 343 my $chmod = 0600; 344 $chmod |= $SHARE_BIT; 345 chmod( $chmod, $rand_file) 346 || die "I need ability to chmod files to adequatetly perform locking"; 347 348 ### lock the locking process 349 local $LOCK_EXTENSION = ".shared"; 350 my $lock = new File::NFSLock { 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. 364 my $success = link( $rand_file, $lock_file); 365 unlink $rand_file; 366 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 379 return 1; 380} 381 382sub do_unlock ($) { 383 return unlink shift->{lock_file}; 384} 385 386sub do_unlock_shared ($) { 387 $errstr = undef; 388 my $self = shift; 389 my $lock_file = $self->{lock_file}; 390 my $lock_line = $self->{lock_line}; 391 392 ### lock the locking process 393 local $LOCK_EXTENSION = '.shared'; 394 my $lock = new File::NFSLock ($lock_file,LOCK_EX,62,60); 395 396 ### get the handle on the lock file 397 local *_FH; 398 if( ! open (_FH,"+<$lock_file") ){ 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 407 my $content = ''; 408 while(defined(my $line=<_FH>)){ 409 next if $line eq $lock_line; 410 $content .= $line; 411 } 412 413 ### other shared locks exist 414 if( length($content) ){ 415 seek _FH, 0, 0; 416 print _FH $content; 417 truncate _FH, length($content); 418 close _FH; 419 420 ### only I exist 421 }else{ 422 close _FH; 423 unlink $lock_file; 424 } 425 426} 427 428sub uncache ($;$) { 429 # allow as method call 430 my $file = pop; 431 ref $file && ($file = $file->{file}); 432 my $rand_file = rand_file( $file ); 433 434 ### hard link to the actual file which will bring it up to date 435 return ( link( $file, $rand_file) && unlink($rand_file) ); 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 # Fake the parent into thinking it is already 460 # unlocked because the child will take care of it. 461 $self->{unlocked} = 1; 462 } else { 463 # This is the new child 464 465 # The lock_line found in the lock_file contents 466 # must be modified to reflect the new pid. 467 468 # Fix lock_pid to the new pid. 469 $self->{lock_pid} = $$; 470 # Backup the old lock_line. 471 my $old_line = $self->{lock_line}; 472 # Clear lock_line to create a fresh one. 473 delete $self->{lock_line}; 474 # Append a new lock_line to the lock_file. 475 $self->create_magic($self->{lock_file}); 476 # Remove the old lock_line from lock_file. 477 local $self->{lock_line} = $old_line; 478 $self->do_unlock_shared; 479 # Create signal file to notify parent that 480 # the lock_line entry has been delegated. 481 open (_FH, ">$self->{lock_file}.fork"); 482 close(_FH); 483 } 484} 485 4861; 487 488 489=head1 NAME 490 491File::NFSLock - perl module to do NFS (or not) locking 492 493=head1 SYNOPSIS 494 495 use File::NFSLock qw(uncache); 496 use Fcntl qw(LOCK_EX LOCK_NB); 497 498 my $file = "somefile"; 499 500 ### set up a lock - lasts until object looses scope 501 if (my $lock = new File::NFSLock { 502 file => $file, 503 lock_type => LOCK_EX|LOCK_NB, 504 blocking_timeout => 10, # 10 sec 505 stale_lock_timeout => 30 * 60, # 30 min 506 }) { 507 508 ### OR 509 ### my $lock = File::NFSLock->new($file,LOCK_EX|LOCK_NB,10,30*60); 510 511 ### do write protected stuff on $file 512 ### at this point $file is uncached from NFS (most recent) 513 open(FILE, "+<$file") || die $!; 514 515 ### or open it any way you like 516 ### my $fh = IO::File->open( $file, 'w' ) || die $! 517 518 ### update (uncache across NFS) other files 519 uncache("someotherfile1"); 520 uncache("someotherfile2"); 521 # open(FILE2,"someotherfile1"); 522 523 ### unlock it 524 $lock->unlock(); 525 ### OR 526 ### undef $lock; 527 ### OR let $lock go out of scope 528 }else{ 529 die "I couldn't lock the file [$File::NFSLock::errstr]"; 530 } 531 532 533=head1 DESCRIPTION 534 535Program based of concept of hard linking of files being atomic across 536NFS. This concept was mentioned in Mail::Box::Locker (which was 537originally presented in Mail::Folder::Maildir). Some routine flow is 538taken from there -- particularly the idea of creating a random local 539file, hard linking a common file to the local file, and then checking 540the nlink status. Some ideologies were not complete (uncache 541mechanism, shared locking) and some coding was even incorrect (wrong 542stat index). File::NFSLock was written to be light, generic, 543and fast. 544 545 546=head1 USAGE 547 548Locking occurs by creating a File::NFSLock object. If the object 549is created successfully, a lock is currently in place and remains in 550place until the lock object goes out of scope (or calls the unlock 551method). 552 553A lock object is created by calling the new method and passing two 554to four parameters in the following manner: 555 556 my $lock = File::NFSLock->new($file, 557 $lock_type, 558 $blocking_timeout, 559 $stale_lock_timeout, 560 ); 561 562Additionally, parameters may be passed as a hashref: 563 564 my $lock = File::NFSLock->new({ 565 file => $file, 566 lock_type => $lock_type, 567 blocking_timeout => $blocking_timeout, 568 stale_lock_timeout => $stale_lock_timeout, 569 }); 570 571=head1 PARAMETERS 572 573=over 4 574 575=item Parameter 1: file 576 577Filename of the file upon which it is anticipated that a write will 578happen to. Locking will provide the most recent version (uncached) 579of this file upon a successful file lock. It is not necessary 580for this file to exist. 581 582=item Parameter 2: lock_type 583 584Lock type must be one of the following: 585 586 BLOCKING 587 BL 588 EXCLUSIVE (BLOCKING) 589 EX 590 NONBLOCKING 591 NB 592 SHARED 593 SH 594 595Or else one or more of the following joined with '|': 596 597 Fcntl::LOCK_EX() (BLOCKING) 598 Fcntl::LOCK_NB() (NONBLOCKING) 599 Fcntl::LOCK_SH() (SHARED) 600 601Lock type determines whether the lock will be blocking, non blocking, 602or shared. Blocking locks will wait until other locks are removed 603before the process continues. Non blocking locks will return undef if 604another process currently has the lock. Shared will allow other 605process to do a shared lock at the same time as long as there is not 606already an exclusive lock obtained. 607 608=item Parameter 3: blocking_timeout (optional) 609 610Timeout is used in conjunction with a blocking timeout. If specified, 611File::NFSLock will block up to the number of seconds specified in 612timeout before returning undef (could not get a lock). 613 614 615=item Parameter 4: stale_lock_timeout (optional) 616 617Timeout is used to see if an existing lock file is older than the stale 618lock timeout. If do_lock fails to get a lock, the modified time is checked 619and do_lock is attempted again. If the stale_lock_timeout is set to low, a 620recursion load could exist so do_lock will only recurse 10 times (this is only 621a problem if the stale_lock_timeout is set too low -- on the order of one or two 622seconds). 623 624=head1 METHODS 625 626After the $lock object is instantiated with new, 627as outlined above, some methods may be used for 628additional functionality. 629 630=head2 unlock 631 632 $lock->unlock; 633 634This method may be used to explicitly release a lock 635that is aquired. In most cases, it is not necessary 636to call unlock directly since it will implicitly be 637called when the object leaves whatever scope it is in. 638 639=head2 uncache 640 641 $lock->uncache; 642 $lock->uncache("otherfile1"); 643 uncache("otherfile2"); 644 645This method is used to freshen up the contents of a 646file across NFS, ignoring what is contained in the 647NFS client cache. It is always called from within 648the new constructor on the file that the lock is 649being attempted. uncache may be used as either an 650object method or as a stand alone subroutine. 651 652=head2 newpid 653 654 my $pid = fork; 655 if (defined $pid) { 656 # Fork Failed 657 } elsif ($pid) { 658 $lock->newpid; # Parent 659 } else { 660 $lock->newpid; # Child 661 } 662 663If fork() is called after a lock has been aquired, 664then when the lock object leaves scope in either 665the parent or child, it will be released. This 666behavior may be inappropriate for your application. 667To delegate ownership of the lock from the parent 668to the child, both the parent and child process 669must call the newpid() method after a successful 670fork() call. This will prevent the parent from 671releasing the lock when unlock is called or when 672the lock object leaves scope. This is also 673useful to allow the parent to fail on subsequent 674lock attempts if the child lock is still aquired. 675 676=head1 FAILURE 677 678On failure, a global variable, $File::NFSLock::errstr, should be set and should 679contain the cause for the failure to get a lock. Useful primarily for debugging. 680 681=head1 LOCK_EXTENSION 682 683By default File::NFSLock will use a lock file extenstion of ".NFSLock". This is 684in a global variable $File::NFSLock::LOCK_EXTENSION that may be changed to 685suit other purposes (such as compatibility in mail systems). 686 687=head1 BUGS 688 689Notify paul@seamons.com or bbb@cpan.org if you spot anything. 690 691=head2 FIFO 692 693Locks are not necessarily obtained on a first come first serve basis. 694Not only does this not seem fair to new processes trying to obtain a lock, 695but it may cause a process starvation condition on heavily locked files. 696 697 698=head2 DIRECTORIES 699 700Locks cannot be obtained on directory nodes, nor can a directory node be 701uncached with the uncache routine because hard links do not work with 702directory nodes. Some other algorithm might be used to uncache a 703directory, but I am unaware of the best way to do it. The biggest use I 704can see would be to avoid NFS cache of directory modified and last accessed 705timestamps. 706 707=head1 INSTALL 708 709Download and extract tarball before running 710these commands in its base directory: 711 712 perl Makefile.PL 713 make 714 make test 715 make install 716 717For RPM installation, download tarball before 718running these commands in your _topdir: 719 720 rpm -ta SOURCES/File-NFSLock-*.tar.gz 721 rpm -ih RPMS/noarch/perl-File-NFSLock-*.rpm 722 723=head1 AUTHORS 724 725Paul T Seamons (paul@seamons.com) - Performed majority of the 726programming with copious amounts of input from Rob Brown. 727 728Rob B Brown (bbb@cpan.org) - In addition to helping in the 729programming, Rob Brown provided most of the core testing to make sure 730implementation worked properly. He is now the current maintainer. 731 732Also Mark Overmeer (mark@overmeer.net) - Author of Mail::Box::Locker, 733from which some key concepts for File::NFSLock were taken. 734 735Also Kevin Johnson (kjj@pobox.com) - Author of Mail::Folder::Maildir, 736from which Mark Overmeer based Mail::Box::Locker. 737 738=head1 COPYRIGHT 739 740 Copyright (C) 2001 741 Paul T Seamons 742 paul@seamons.com 743 http://seamons.com/ 744 745 Copyright (C) 2002-2003, 746 Rob B Brown 747 bbb@cpan.org 748 749 This package may be distributed under the terms of either the 750 GNU General Public License 751 or the 752 Perl Artistic License 753 754 All rights reserved. 755 756=cut 757