File-NFSLock-1.21/0000755000076400007640000000000011607446326011720 5ustar robrobFile-NFSLock-1.21/lib/0000755000076400007640000000000011607446326012466 5ustar robrobFile-NFSLock-1.21/lib/File/0000755000076400007640000000000011607446326013345 5ustar robrobFile-NFSLock-1.21/lib/File/NFSLock.pm0000644000076400007640000005112211607446263015143 0ustar robrob# -*- perl -*- # # File::NFSLock - bdpO - NFS compatible (safe) locking utility # # $Id: NFSLock.pm,v 1.34 2003/05/13 18:06:41 hookbot Exp $ # # Copyright (C) 2002, Paul T Seamons # paul@seamons.com # http://seamons.com/ # # Rob B Brown # bbb@cpan.org # # This package may be distributed under the terms of either the # GNU General Public License # or the # Perl Artistic License # # All rights reserved. # # Please read the perldoc File::NFSLock # ################################################################ package File::NFSLock; use strict; use warnings; use Carp qw(croak confess); our $errstr; use base 'Exporter'; our @EXPORT_OK = qw(uncache); our $VERSION = '1.21'; #Get constants, but without the bloat of #use Fcntl qw(LOCK_SH LOCK_EX LOCK_NB); use constant { LOCK_SH => 1, LOCK_EX => 2, LOCK_NB => 4, }; ### Convert lock_type to a number our $TYPES = { BLOCKING => LOCK_EX, BL => LOCK_EX, EXCLUSIVE => LOCK_EX, EX => LOCK_EX, NONBLOCKING => LOCK_EX | LOCK_NB, NB => LOCK_EX | LOCK_NB, SHARED => LOCK_SH, SH => LOCK_SH, }; our $LOCK_EXTENSION = '.NFSLock'; # customizable extension our $HOSTNAME = undef; our $SHARE_BIT = 1; ###----------------------------------------------------------------### my $graceful_sig = sub { print STDERR "Received SIG$_[0]\n" if @_; # Perl's exit should safely DESTROY any objects # still "alive" before calling the real _exit(). exit; }; our @CATCH_SIGS = qw(TERM INT); sub new { $errstr = undef; my $type = shift; my $class = ref($type) || $type || __PACKAGE__; my $self = {}; ### allow for arguments by hash ref or serially if( @_ && ref $_[0] ){ $self = shift; }else{ $self->{file} = shift; $self->{lock_type} = shift; $self->{blocking_timeout} = shift; $self->{stale_lock_timeout} = shift; } $self->{file} ||= ""; $self->{lock_type} ||= 0; $self->{blocking_timeout} ||= 0; $self->{stale_lock_timeout} ||= 0; $self->{lock_pid} = $$; $self->{unlocked} = 1; foreach my $signal (@CATCH_SIGS) { if (!$SIG{$signal} || $SIG{$signal} eq "DEFAULT") { $SIG{$signal} = $graceful_sig; } } ### force lock_type to be numerical if( $self->{lock_type} && $self->{lock_type} !~ /^\d+/ && exists $TYPES->{$self->{lock_type}} ){ $self->{lock_type} = $TYPES->{$self->{lock_type}}; } ### need the hostname if( !$HOSTNAME ){ require Sys::Hostname; $HOSTNAME = Sys::Hostname::hostname(); } ### quick usage check croak ($errstr = "Usage: my \$f = $class->new('/pathtofile/file',\n" ."'BLOCKING|EXCLUSIVE|NONBLOCKING|SHARED', [blocking_timeout, stale_lock_timeout]);\n" ."(You passed \"$self->{file}\" and \"$self->{lock_type}\")") unless length($self->{file}); croak ($errstr = "Unrecognized lock_type operation setting [$self->{lock_type}]") unless $self->{lock_type} && $self->{lock_type} =~ /^\d+$/; ### Input syntax checking passed, ready to bless bless $self, $class; ### choose a random filename $self->{rand_file} = rand_file( $self->{file} ); ### choose the lock filename $self->{lock_file} = $self->{file} . $LOCK_EXTENSION; my $quit_time = $self->{blocking_timeout} && !($self->{lock_type} & LOCK_NB) ? time() + $self->{blocking_timeout} : 0; ### remove an old lockfile if it is older than the stale_timeout if( -e $self->{lock_file} && $self->{stale_lock_timeout} > 0 && time() - (stat _)[9] > $self->{stale_lock_timeout} ){ unlink $self->{lock_file}; } while (1) { ### open the temporary file $self->create_magic or return undef; if ( $self->{lock_type} & LOCK_EX ) { last if $self->do_lock; } elsif ( $self->{lock_type} & LOCK_SH ) { last if $self->do_lock_shared; } else { $errstr = "Unknown lock_type [$self->{lock_type}]"; return undef; } ### Lock failed! ### I know this may be a race condition, but it's okay. It is just a ### stab in the dark to possibly find long dead processes. ### If lock exists and is readable, see who is mooching on the lock my $fh; if ( -e $self->{lock_file} && open ($fh,'+<', $self->{lock_file}) ){ my @mine = (); my @them = (); my @dead = (); my $has_lock_exclusive = !((stat _)[2] & $SHARE_BIT); my $try_lock_exclusive = !($self->{lock_type} & LOCK_SH); while(defined(my $line=<$fh>)){ if ($line =~ /^$HOSTNAME (-?\d+) /) { my $pid = $1; if ($pid == $$) { # This is me. push @mine, $line; }elsif(kill 0, $pid) { # Still running on this host. push @them, $line; }else{ # Finished running on this host. push @dead, $line; } } else { # Running on another host, so push @them, $line; # assume it is still running. } } ### If there was at least one stale lock discovered... if (@dead) { # Lock lock_file to avoid a race condition. local $LOCK_EXTENSION = ".shared"; my $lock = new File::NFSLock { file => $self->{lock_file}, lock_type => LOCK_EX, blocking_timeout => 62, stale_lock_timeout => 60, }; ### Rescan in case lock contents were modified between time stale lock ### was discovered and lockfile lock was acquired. seek ($fh, 0, 0); my $content = ''; while(defined(my $line=<$fh>)){ if ($line =~ /^$HOSTNAME (-?\d+) /) { my $pid = $1; next if (!kill 0, $pid); # Skip dead locks from this host } $content .= $line; # Save valid locks } ### Save any valid locks or wipe file. if( length($content) ){ seek $fh, 0, 0; print $fh $content; truncate $fh, length($content); close $fh; }else{ close $fh; unlink $self->{lock_file}; } ### No "dead" or stale locks found. } else { close $fh; } ### If attempting to acquire the same type of lock ### that it is already locked with, and I've already ### locked it myself, then it is safe to lock again. ### Just kick out successfully without really locking. ### Assumes locks will be released in the reverse ### order from how they were established. if ($try_lock_exclusive eq $has_lock_exclusive && @mine){ return $self; } } ### If non-blocking, then kick out now. ### ($errstr might already be set to the reason.) if ($self->{lock_type} & LOCK_NB) { $errstr ||= "NONBLOCKING lock failed!"; return undef; } ### wait a moment sleep(1); ### but don't wait past the time out if( $quit_time && (time > $quit_time) ){ $errstr = "Timed out waiting for blocking lock"; return undef; } # BLOCKING Lock, So Keep Trying } ### clear up the NFS cache $self->uncache; ### Yes, the lock has been aquired. delete $self->{unlocked}; return $self; } sub DESTROY { shift()->unlock(); } sub unlock ($) { my $self = shift; if (!$self->{unlocked}) { unlink( $self->{rand_file} ) if -e $self->{rand_file}; if( $self->{lock_type} & LOCK_SH ){ return $self->do_unlock_shared; }else{ return $self->do_unlock; } $self->{unlocked} = 1; foreach my $signal (@CATCH_SIGS) { if ($SIG{$signal} && ($SIG{$signal} eq $graceful_sig)) { # Revert handler back to how it used to be. # Unfortunately, this will restore the # handler back even if there are other # locks still in tact, but for most cases, # it will still be an improvement. delete $SIG{$signal}; } } } return 1; } ###----------------------------------------------------------------### # concepts for these routines were taken from Mail::Box which # took the concepts from Mail::Folder sub rand_file ($) { my $file = shift; "$file.tmp.". time()%10000 .'.'. $$ .'.'. int(rand()*10000); } sub create_magic ($;$) { $errstr = undef; my $self = shift; my $append_file = shift || $self->{rand_file}; $self->{lock_line} ||= "$HOSTNAME $self->{lock_pid} ".time()." ".int(rand()*10000)."\n"; open (my $fh,'>>', $append_file) or do { $errstr = "Couldn't open \"$append_file\" [$!]"; return undef; }; print $fh $self->{lock_line}; close $fh; return 1; } sub do_lock { $errstr = undef; my $self = shift; my $lock_file = $self->{lock_file}; my $rand_file = $self->{rand_file}; my $chmod = 0600; chmod( $chmod, $rand_file) || die "I need ability to chmod files to adequatetly perform locking"; ### try a hard link, if it worked ### two files are pointing to $rand_file my $success = link( $rand_file, $lock_file ) && -e $rand_file && (stat _)[3] == 2; unlink $rand_file; return $success; } sub do_lock_shared { $errstr = undef; my $self = shift; my $lock_file = $self->{lock_file}; my $rand_file = $self->{rand_file}; ### chmod local file to make sure we know before my $chmod = 0600; $chmod |= $SHARE_BIT; chmod( $chmod, $rand_file) || die "I need ability to chmod files to adequatetly perform locking"; ### lock the locking process local $LOCK_EXTENSION = ".shared"; my $lock = new File::NFSLock { file => $lock_file, lock_type => LOCK_EX, blocking_timeout => 62, stale_lock_timeout => 60, }; # The ".shared" lock will be released as this status # is returned, whether or not the status is successful. ### If I didn't have exclusive and the shared bit is not ### set, I have failed ### Try to create $lock_file from the special ### file with the magic $SHARE_BIT set. my $success = link( $rand_file, $lock_file); unlink $rand_file; if ( !$success && -e $lock_file && ((stat _)[2] & $SHARE_BIT) != $SHARE_BIT ){ $errstr = 'Exclusive lock exists.'; return undef; } elsif ( !$success ) { ### Shared lock exists, append my lock $self->create_magic ($self->{lock_file}); } # Success return 1; } sub do_unlock ($) { return unlink shift->{lock_file}; } sub do_unlock_shared ($) { $errstr = undef; my $self = shift; my $lock_file = $self->{lock_file}; my $lock_line = $self->{lock_line}; ### lock the locking process local $LOCK_EXTENSION = '.shared'; my $lock = new File::NFSLock ($lock_file,LOCK_EX,62,60); ### get the handle on the lock file my $fh; if( ! open ($fh,'+<', $lock_file) ){ if( ! -e $lock_file ){ return 1; }else{ die "Could not open for writing shared lock file $lock_file ($!)"; } } ### read existing file my $content = ''; while(defined(my $line=<$fh>)){ next if $line eq $lock_line; $content .= $line; } ### other shared locks exist if( length($content) ){ seek $fh, 0, 0; print $fh $content; truncate $fh, length($content); close $fh; ### only I exist }else{ close $fh; unlink $lock_file; } } sub uncache ($;$) { # allow as method call my $file = pop; ref $file && ($file = $file->{file}); my $rand_file = rand_file( $file ); ### hard link to the actual file which will bring it up to date return ( link( $file, $rand_file) && unlink($rand_file) ); } sub newpid { my $self = shift; # Detect if this is the parent or the child if ($self->{lock_pid} == $$) { # This is the parent # Must wait for child to call newpid before processing. # A little patience for the child to call newpid my $patience = time + 10; while (time < $patience) { if (rename("$self->{lock_file}.fork",$self->{rand_file})) { # Child finished its newpid call. # Wipe the signal file. unlink $self->{rand_file}; last; } # Brief pause before checking again # to avoid intensive IO across NFS. select(undef,undef,undef,0.1); } # Fake the parent into thinking it is already # unlocked because the child will take care of it. $self->{unlocked} = 1; } else { # This is the new child # The lock_line found in the lock_file contents # must be modified to reflect the new pid. # Fix lock_pid to the new pid. $self->{lock_pid} = $$; # Backup the old lock_line. my $old_line = $self->{lock_line}; # Clear lock_line to create a fresh one. delete $self->{lock_line}; # Append a new lock_line to the lock_file. $self->create_magic($self->{lock_file}); # Remove the old lock_line from lock_file. local $self->{lock_line} = $old_line; $self->do_unlock_shared; # Create signal file to notify parent that # the lock_line entry has been delegated. open (my $fh, '>', "$self->{lock_file}.fork"); close($fh); } } 1; =head1 NAME File::NFSLock - perl module to do NFS (or not) locking =head1 SYNOPSIS use File::NFSLock qw(uncache); use Fcntl qw(LOCK_EX LOCK_NB); my $file = "somefile"; ### set up a lock - lasts until object looses scope if (my $lock = new File::NFSLock { file => $file, lock_type => LOCK_EX|LOCK_NB, blocking_timeout => 10, # 10 sec stale_lock_timeout => 30 * 60, # 30 min }) { ### OR ### my $lock = File::NFSLock->new($file,LOCK_EX|LOCK_NB,10,30*60); ### do write protected stuff on $file ### at this point $file is uncached from NFS (most recent) open(FILE, "+<$file") || die $!; ### or open it any way you like ### my $fh = IO::File->open( $file, 'w' ) || die $! ### update (uncache across NFS) other files uncache("someotherfile1"); uncache("someotherfile2"); # open(FILE2,"someotherfile1"); ### unlock it $lock->unlock(); ### OR ### undef $lock; ### OR let $lock go out of scope }else{ die "I couldn't lock the file [$File::NFSLock::errstr]"; } =head1 DESCRIPTION Program based of concept of hard linking of files being atomic across NFS. This concept was mentioned in Mail::Box::Locker (which was originally presented in Mail::Folder::Maildir). Some routine flow is taken from there -- particularly the idea of creating a random local file, hard linking a common file to the local file, and then checking the nlink status. Some ideologies were not complete (uncache mechanism, shared locking) and some coding was even incorrect (wrong stat index). File::NFSLock was written to be light, generic, and fast. =head1 USAGE Locking occurs by creating a File::NFSLock object. If the object is created successfully, a lock is currently in place and remains in place until the lock object goes out of scope (or calls the unlock method). A lock object is created by calling the new method and passing two to four parameters in the following manner: my $lock = File::NFSLock->new($file, $lock_type, $blocking_timeout, $stale_lock_timeout, ); Additionally, parameters may be passed as a hashref: my $lock = File::NFSLock->new({ file => $file, lock_type => $lock_type, blocking_timeout => $blocking_timeout, stale_lock_timeout => $stale_lock_timeout, }); =head1 PARAMETERS =over 4 =item Parameter 1: file Filename of the file upon which it is anticipated that a write will happen to. Locking will provide the most recent version (uncached) of this file upon a successful file lock. It is not necessary for this file to exist. =item Parameter 2: lock_type Lock type must be one of the following: BLOCKING BL EXCLUSIVE (BLOCKING) EX NONBLOCKING NB SHARED SH Or else one or more of the following joined with '|': Fcntl::LOCK_EX() (BLOCKING) Fcntl::LOCK_NB() (NONBLOCKING) Fcntl::LOCK_SH() (SHARED) Lock type determines whether the lock will be blocking, non blocking, or shared. Blocking locks will wait until other locks are removed before the process continues. Non blocking locks will return undef if another process currently has the lock. Shared will allow other process to do a shared lock at the same time as long as there is not already an exclusive lock obtained. =item Parameter 3: blocking_timeout (optional) Timeout is used in conjunction with a blocking timeout. If specified, File::NFSLock will block up to the number of seconds specified in timeout before returning undef (could not get a lock). =item Parameter 4: stale_lock_timeout (optional) Timeout is used to see if an existing lock file is older than the stale lock timeout. If do_lock fails to get a lock, the modified time is checked and do_lock is attempted again. If the stale_lock_timeout is set to low, a recursion load could exist so do_lock will only recurse 10 times (this is only a problem if the stale_lock_timeout is set too low -- on the order of one or two seconds). =head1 METHODS After the $lock object is instantiated with new, as outlined above, some methods may be used for additional functionality. =head2 unlock $lock->unlock; This method may be used to explicitly release a lock that is aquired. In most cases, it is not necessary to call unlock directly since it will implicitly be called when the object leaves whatever scope it is in. =head2 uncache $lock->uncache; $lock->uncache("otherfile1"); uncache("otherfile2"); This method is used to freshen up the contents of a file across NFS, ignoring what is contained in the NFS client cache. It is always called from within the new constructor on the file that the lock is being attempted. uncache may be used as either an object method or as a stand alone subroutine. =head2 newpid my $pid = fork; if (defined $pid) { # Fork Failed } elsif ($pid) { $lock->newpid; # Parent } else { $lock->newpid; # Child } If fork() is called after a lock has been aquired, then when the lock object leaves scope in either the parent or child, it will be released. This behavior may be inappropriate for your application. To delegate ownership of the lock from the parent to the child, both the parent and child process must call the newpid() method after a successful fork() call. This will prevent the parent from releasing the lock when unlock is called or when the lock object leaves scope. This is also useful to allow the parent to fail on subsequent lock attempts if the child lock is still aquired. =head1 FAILURE On failure, a global variable, $File::NFSLock::errstr, should be set and should contain the cause for the failure to get a lock. Useful primarily for debugging. =head1 LOCK_EXTENSION By default File::NFSLock will use a lock file extenstion of ".NFSLock". This is in a global variable $File::NFSLock::LOCK_EXTENSION that may be changed to suit other purposes (such as compatibility in mail systems). =head1 BUGS Notify paul@seamons.com or bbb@cpan.org if you spot anything. =head2 FIFO Locks are not necessarily obtained on a first come first serve basis. Not only does this not seem fair to new processes trying to obtain a lock, but it may cause a process starvation condition on heavily locked files. =head2 DIRECTORIES Locks cannot be obtained on directory nodes, nor can a directory node be uncached with the uncache routine because hard links do not work with directory nodes. Some other algorithm might be used to uncache a directory, but I am unaware of the best way to do it. The biggest use I can see would be to avoid NFS cache of directory modified and last accessed timestamps. =head1 INSTALL Download and extract tarball before running these commands in its base directory: perl Makefile.PL make make test make install For RPM installation, download tarball before running these commands in your _topdir: rpm -ta SOURCES/File-NFSLock-*.tar.gz rpm -ih RPMS/noarch/perl-File-NFSLock-*.rpm =head1 AUTHORS Paul T Seamons (paul@seamons.com) - Performed majority of the programming with copious amounts of input from Rob Brown. Rob B Brown (bbb@cpan.org) - In addition to helping in the programming, Rob Brown provided most of the core testing to make sure implementation worked properly. He is now the current maintainer. Also Mark Overmeer (mark@overmeer.net) - Author of Mail::Box::Locker, from which some key concepts for File::NFSLock were taken. Also Kevin Johnson (kjj@pobox.com) - Author of Mail::Folder::Maildir, from which Mark Overmeer based Mail::Box::Locker. =head1 COPYRIGHT Copyright (C) 2001 Paul T Seamons paul@seamons.com http://seamons.com/ Copyright (C) 2002-2003, Rob B Brown bbb@cpan.org This package may be distributed under the terms of either the GNU General Public License or the Perl Artistic License All rights reserved. =cut File-NFSLock-1.21/README0000644000076400007640000002137111607446267012610 0ustar robrobNAME File::NFSLock - perl module to do NFS (or not) locking SYNOPSIS use File::NFSLock qw(uncache); use Fcntl qw(LOCK_EX LOCK_NB); my $file = "somefile"; ### set up a lock - lasts until object looses scope if (my $lock = new File::NFSLock { file => $file, lock_type => LOCK_EX|LOCK_NB, blocking_timeout => 10, # 10 sec stale_lock_timeout => 30 * 60, # 30 min }) { ### OR ### my $lock = File::NFSLock->new($file,LOCK_EX|LOCK_NB,10,30*60); ### do write protected stuff on $file ### at this point $file is uncached from NFS (most recent) open(FILE, "+<$file") || die $!; ### or open it any way you like ### my $fh = IO::File->open( $file, 'w' ) || die $! ### update (uncache across NFS) other files uncache("someotherfile1"); uncache("someotherfile2"); # open(FILE2,"someotherfile1"); ### unlock it $lock->unlock(); ### OR ### undef $lock; ### OR let $lock go out of scope }else{ die "I couldn't lock the file [$File::NFSLock::errstr]"; } DESCRIPTION Program based of concept of hard linking of files being atomic across NFS. This concept was mentioned in Mail::Box::Locker (which was originally presented in Mail::Folder::Maildir). Some routine flow is taken from there -- particularly the idea of creating a random local file, hard linking a common file to the local file, and then checking the nlink status. Some ideologies were not complete (uncache mechanism, shared locking) and some coding was even incorrect (wrong stat index). File::NFSLock was written to be light, generic, and fast. USAGE Locking occurs by creating a File::NFSLock object. If the object is created successfully, a lock is currently in place and remains in place until the lock object goes out of scope (or calls the unlock method). A lock object is created by calling the new method and passing two to four parameters in the following manner: my $lock = File::NFSLock->new($file, $lock_type, $blocking_timeout, $stale_lock_timeout, ); Additionally, parameters may be passed as a hashref: my $lock = File::NFSLock->new({ file => $file, lock_type => $lock_type, blocking_timeout => $blocking_timeout, stale_lock_timeout => $stale_lock_timeout, }); PARAMETERS Parameter 1: file Filename of the file upon which it is anticipated that a write will happen to. Locking will provide the most recent version (uncached) of this file upon a successful file lock. It is not necessary for this file to exist. Parameter 2: lock_type Lock type must be one of the following: BLOCKING BL EXCLUSIVE (BLOCKING) EX NONBLOCKING NB SHARED SH Or else one or more of the following joined with '|': Fcntl::LOCK_EX() (BLOCKING) Fcntl::LOCK_NB() (NONBLOCKING) Fcntl::LOCK_SH() (SHARED) Lock type determines whether the lock will be blocking, non blocking, or shared. Blocking locks will wait until other locks are removed before the process continues. Non blocking locks will return undef if another process currently has the lock. Shared will allow other process to do a shared lock at the same time as long as there is not already an exclusive lock obtained. Parameter 3: blocking_timeout (optional) Timeout is used in conjunction with a blocking timeout. If specified, File::NFSLock will block up to the number of seconds specified in timeout before returning undef (could not get a lock). Parameter 4: stale_lock_timeout (optional) Timeout is used to see if an existing lock file is older than the stale lock timeout. If do_lock fails to get a lock, the modified time is checked and do_lock is attempted again. If the stale_lock_timeout is set to low, a recursion load could exist so do_lock will only recurse 10 times (this is only a problem if the stale_lock_timeout is set too low -- on the order of one or two seconds). METHODS After the $lock object is instantiated with new, as outlined above, some methods may be used for additional functionality. unlock $lock->unlock; This method may be used to explicitly release a lock that is aquired. In most cases, it is not necessary to call unlock directly since it will implicitly be called when the object leaves whatever scope it is in. uncache $lock->uncache; $lock->uncache("otherfile1"); uncache("otherfile2"); This method is used to freshen up the contents of a file across NFS, ignoring what is contained in the NFS client cache. It is always called from within the new constructor on the file that the lock is being attempted. uncache may be used as either an object method or as a stand alone subroutine. newpid my $pid = fork; if (defined $pid) { # Fork Failed } elsif ($pid) { $lock->newpid; # Parent } else { $lock->newpid; # Child } If fork() is called after a lock has been aquired, then when the lock object leaves scope in either the parent or child, it will be released. This behavior may be inappropriate for your application. To delegate ownership of the lock from the parent to the child, both the parent and child process must call the newpid() method after a successful fork() call. This will prevent the parent from releasing the lock when unlock is called or when the lock object leaves scope. This is also useful to allow the parent to fail on subsequent lock attempts if the child lock is still aquired. FAILURE On failure, a global variable, $File::NFSLock::errstr, should be set and should contain the cause for the failure to get a lock. Useful primarily for debugging. LOCK_EXTENSION By default File::NFSLock will use a lock file extenstion of ".NFSLock". This is in a global variable $File::NFSLock::LOCK_EXTENSION that may be changed to suit other purposes (such as compatibility in mail systems). BUGS Notify paul@seamons.com or bbb@cpan.org if you spot anything. FIFO Locks are not necessarily obtained on a first come first serve basis. Not only does this not seem fair to new processes trying to obtain a lock, but it may cause a process starvation condition on heavily locked files. DIRECTORIES Locks cannot be obtained on directory nodes, nor can a directory node be uncached with the uncache routine because hard links do not work with directory nodes. Some other algorithm might be used to uncache a directory, but I am unaware of the best way to do it. The biggest use I can see would be to avoid NFS cache of directory modified and last accessed timestamps. INSTALL Download and extract tarball before running these commands in its base directory: perl Makefile.PL make make test make install For RPM installation, download tarball before running these commands in your _topdir: rpm -ta SOURCES/File-NFSLock-*.tar.gz rpm -ih RPMS/noarch/perl-File-NFSLock-*.rpm AUTHORS Paul T Seamons (paul@seamons.com) - Performed majority of the programming with copious amounts of input from Rob Brown. Rob B Brown (bbb@cpan.org) - In addition to helping in the programming, Rob Brown provided most of the core testing to make sure implementation worked properly. He is now the current maintainer. Also Mark Overmeer (mark@overmeer.net) - Author of Mail::Box::Locker, from which some key concepts for File::NFSLock were taken. Also Kevin Johnson (kjj@pobox.com) - Author of Mail::Folder::Maildir, from which Mark Overmeer based Mail::Box::Locker. COPYRIGHT Copyright (C) 2001 Paul T Seamons paul@seamons.com http://seamons.com/ Copyright (C) 2002-2003, Rob B Brown bbb@cpan.org This package may be distributed under the terms of either the GNU General Public License or the Perl Artistic License All rights reserved. File-NFSLock-1.21/META.yml0000664000076400007640000000046411607446326013177 0ustar robrob# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: File-NFSLock version: 1.21 version_from: lib/File/NFSLock.pm installdirs: site requires: distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30 File-NFSLock-1.21/t/0000755000076400007640000000000011607446326012163 5ustar robrobFile-NFSLock-1.21/t/110_compare.t0000644000076400007640000000046411607126675014365 0ustar robrobuse strict; use warnings; use Test::More tests => 3; use File::NFSLock; use Fcntl; # Make sure File::NFSLock has the correct # constants according to Fcntl is (&File::NFSLock::LOCK_SH(),&Fcntl::LOCK_SH()); is (&File::NFSLock::LOCK_EX(),&Fcntl::LOCK_EX()); is (&File::NFSLock::LOCK_NB(),&Fcntl::LOCK_NB()); File-NFSLock-1.21/t/240_fork.t0000644000076400007640000000321711607126675013703 0ustar robrob# Fork Test # # This tests the capabilities of fork after lock to # allow a parent to delegate the lock to its child. use strict; use warnings; use Test::More tests => 5; use File::NFSLock; use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC O_APPEND LOCK_EX LOCK_SH LOCK_NB); $| = 1; # Buffer must be autoflushed because of fork() below. my $datafile = "testfile.dat"; # Wipe lock file in case it exists unlink ("$datafile$File::NFSLock::LOCK_EXTENSION"); # Create a blank file sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); close ($fh); ok (-e $datafile && !-s _); if (1) { # Forced dummy scope my $lock1 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, }; ok ($lock1); my $pid = fork; if (!defined $pid) { die "fork failed!"; } elsif (!$pid) { # Child process # Test possible race condition # by making parent reach newpid() # and attempt relock before child # even calls newpid() the first time. sleep 2; $lock1->newpid; # Act busy for a while sleep 5; # Now release lock exit; } else { # Fork worked ok 1; # Avoid releasing lock # because child should do it. $lock1->newpid; } } # Lock is out of scope, but # should still be acquired. #sysopen(FH, $datafile, O_RDWR | O_APPEND); #print FH "lock1\n"; #close FH; # Try to get a non-blocking lock. # Yes, it is the same process, # but it should have been delegated # to the child process. # This lock should fail. my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok (!$lock2); # Wait for child to finish ok(wait); # Wipe the temporary file unlink $datafile; File-NFSLock-1.21/t/220_ex_scope.t0000644000076400007640000000714511607126675014551 0ustar robrob# Non-Blocking Exclusive Lock Scope Test # # This tests to make sure a failed lock leaving # scope does not unlock a lock of someone else. # # Exploits the conditions found by Andy Hird (andyh@myinternet.com.au) # Here are his comments: # # If a process has some file locked (say exclusively although it doesn't matter) and another process attempts to get a lock, if it fails it deletes the lock file - whether or not the first (locking process) has finished with its lock. This means any subsequent process that comes along that attempts to lock the file succeeds - even if the first process thinks it still has a lock. # use strict; use warnings; use Test::More; if( $^O eq 'MSWin32' ) { plan skip_all => 'Tests fail on Win32 due to forking'; } else { plan tests => 11; } use File::NFSLock; use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC LOCK_EX LOCK_NB); $| = 1; # Buffer must be autoflushed because of fork() below. my $datafile = "testfile.dat"; # Create a blank file sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); close ($fh); ok (-e $datafile && !-s _); my ($rd1, $wr1); ok (pipe($rd1, $wr1)); # Connected pipe for child1 if (!fork) { # Child #1 process my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX | LOCK_NB, }; print $wr1 !!$lock; # Send boolean success status down pipe close($wr1); # Signal to parent that the Non-Blocking lock is done close($rd1); if ($lock) { sleep 2; # hold the lock for a moment sysopen(my $fh, $datafile, O_RDWR); # now put a magic word into the file print $fh "child1\n"; close $fh; } exit; } ok 1; # Fork successful close ($wr1); # Waiting for child1 to finish its lock status my $child1_lock = <$rd1>; close ($rd1); # Report status of the child1_lock. # It should have been successful ok ($child1_lock); my ($rd2, $wr2); ok (pipe($rd2, $wr2)); # Connected pipe for child2 if (!fork) { # Child #2 process my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX | LOCK_NB, }; print $wr2 !!$lock; # Send boolean success status down pipe close($wr2); # Signal to parent that the Non-Blocking lock is done close($rd2); if ($lock) { sysopen(my $fh, $datafile, O_RDWR); # now put a magic word into the file print $fh "child2\n"; close $fh; } exit; } ok 1; # Fork successful close ($wr2); # Waiting for child2 to finish its lock status my $child2_lock = <$rd2>; close ($rd2); # Report status of the child2_lock. # This lock should not have been obtained since # the child1 lock should still have been established. ok (!$child2_lock); my ($rd3, $wr3); ok (pipe($rd3, $wr3)); # Connected pipe for child3 if (!fork) { # Child #3 process my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX | LOCK_NB, }; print $wr3 !!$lock; # Send boolean success status down pipe close($wr3); # Signal to parent that the Non-Blocking lock is done close($wr3); if ($lock) { sysopen(my $fh, $datafile, O_RDWR); # now put a magic word into the file print $fh "child3\n"; close $fh; } exit; } ok 1; # Fork successful close ($wr3); # Waiting for child2 to finish its lock status my $child3_lock = <$rd3>; close ($rd3); # Report status of the child3_lock. # This lock should also fail since the child1 # lock should still have been established. ok (!$child3_lock); # Wait until the children have finished. wait; wait; wait; # Load up whatever the file says now sysopen(my $fh2, $datafile, O_RDONLY); $_ = <$fh2>; close $fh2; # It should be child1 if it was really nonblocking # since it got the lock first. ok /child1/; # Wipe the temporary file unlink $datafile; File-NFSLock-1.21/t/200_bl_ex.t0000644000076400007640000000254311607444341014021 0ustar robrob# Blocking Exclusive Lock Test use strict; use warnings; use Test::More; if( $^O eq 'MSWin32' ) { plan skip_all => 'Tests fail on Win32 due to forking'; } else { plan tests => 20+2; } use File::NFSLock; use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC LOCK_EX); # $m simultaneous processes each trying to count to $n my $m = 20; my $n = 50; $| = 1; # Buffer must be autoflushed because of fork() below. my $datafile = "testfile.dat"; # Create a blank file sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); close ($fh); ok (-e $datafile && !-s _); for (my $i = 0; $i < $m ; $i++) { # For each process if (!fork) { # Child process need to count to $n for (my $j = 0; $j < $n ; $j++) { my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, }; sysopen(my $fh, $datafile, O_RDWR); # Read the current value my $count = <$fh>; # Increment it $count ++; # And put it back seek ($fh,0,0); print $fh "$count\n"; close $fh; } exit; } } for (my $i = 0; $i < $m ; $i++) { # Wait until all the children are finished counting wait; ok 1; } # Load up whatever the file says now sysopen(my $fh2, $datafile, O_RDONLY); $_ = <$fh2>; close $fh2; chomp; # It should be $m processes time $n each is $n*$m, $_; # Wipe the temporary file unlink $datafile; File-NFSLock-1.21/t/300_bl_sh.t0000644000076400007640000001242711607126675014031 0ustar robrob# Blocking Shared Lock Test use strict; use warnings; use Test::More; if( $^O eq 'MSWin32' ) { plan skip_all => 'Tests fail on Win32 due to forking'; } else { plan tests => 13+3*20; } use File::NFSLock; use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC O_APPEND LOCK_EX LOCK_NB LOCK_SH); # $m simultaneous processes trying to obtain a shared lock my $m = 20; my $shared_delay = 5; $| = 1; # Buffer must be autoflushed because of fork() below. my $datafile = "testfile.dat"; # Create a blank file sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); close ($fh); # test 1 ok (-e $datafile && !-s _); my ($rd1, $wr1); ok (pipe($rd1, $wr1)); # Connected pipe for child1 if (!fork) { # Child #1 process # Obtain exclusive lock to block the shared attempt later my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, }; print $wr1 !!$lock; # Send boolean success status down pipe close($wr1); # Signal to parent that the Blocking lock is done close($rd1); if ($lock) { sleep 2; # hold the lock for a moment sysopen(my $fh, $datafile, O_RDWR | O_TRUNC); # And then put a magic word into the file print $fh "exclusive\n"; close $fh; } exit; } # test 3 ok 1; # Fork successful close ($wr1); # Waiting for child1 to finish its lock status my $child1_lock = <$rd1>; close ($rd1); # Report status of the child1_lock. # It should have been successful # test 4 ok ($child1_lock); my ($rd2, $wr2); ok (pipe($rd2, $wr2)); # Connected pipe for child2 if (!fork) { # This should block until the exclusive lock is done my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_SH, }; if ($lock) { sysopen(my $fh, $datafile, O_RDWR | O_TRUNC); # Immediately put the magic word into the file print $fh "shared\n"; truncate ($fh, tell $fh); close $fh; # Normally shared locks never modify the contents because # of the race condition. (The last one to write wins.) # But in this case, the parent will wait until the lock # status is reported (close RD2) so it defines execution # sequence will be correct. Hopefully the shared lock # will not happen until the exclusive lock has been released. # This is also a good test to make sure that other shared # locks can still be obtained simultaneously. } print $wr2 !!$lock; # Send boolean success status down pipe close($wr2); # Signal to parent that the Blocking lock is done close($rd2); # Then hold this shared lock for a moment # while other shared locks are attempted sleep($shared_delay*2); exit; # Release the shared lock } # test 6 ok 1; # Fork successful close ($wr2); # Waiting for child2 to finish its lock status my $child2_lock = <$rd2>; close ($rd2); # Report status of the child2_lock. # This should have eventually been successful. # test 7 ok ($child2_lock); # If all these processes take longer than $shared_delay seconds, # then they are probably not running synronously # and the shared lock is not working correctly. # But if all the children obatin the lock simultaneously, # like they're supposed to, then it shouldn't take # much longer than the maximum delay of any of the # shared locks (at least 5 seconds set above). $SIG{ALRM} = sub { # test (unknown) ok 0; die "Shared locks not running simultaneously"; }; # Use pipe to read lock success status from children # test 8 my ($rd3, $wr3); ok (pipe($rd3, $wr3)); # Wait a few seconds less than if all locks were # aquired asyncronously to ensure that they overlap. alarm($m*$shared_delay-2); for (my $i = 0; $i < $m ; $i++) { if (!fork) { # All of these locks should immediately be successful since # there already exist a shared lock. my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_SH, }; # Send boolean success status down pipe print $wr3 !!$lock,"\n"; close($wr3); if ($lock) { sleep $shared_delay; # Hold the shared lock for a moment # Appending should always be safe across NFS sysopen(my $fh, $datafile, O_RDWR | O_APPEND); # Put one line to signal the lock was successful. print $fh "1\n"; close $fh; $lock->unlock(); } else { warn "Lock [$i] failed!"; } exit; } } # Parent process never writes to pipe close($wr3); # There were $m children attempting the shared locks. for (my $i = 0; $i < $m ; $i++) { # Report status of each lock attempt. my $got_shared_lock = <$rd3>; # test 9 .. 8+$m ok $got_shared_lock; } # There should not be anything left in the pipe. my $extra = <$rd3>; # test 9 + $m ok !$extra; close ($rd3); # If we made it here, then it must have been faster # than the timeout. So reset the timer. alarm(0); # test 10 + $m ok 1; # There are $m children plus the child1 exclusive locker # and the child2 obtaining the first shared lock. for (my $i = 0; $i < $m + 2 ; $i++) { # Wait until all the children are finished. wait; # test 11+$m .. 12+2*$m ok 1; } # Load up whatever the file says now sysopen(my $fh2, $datafile, O_RDONLY); # The first line should say "shared" if child2 really # waited for child1's exclusive lock to finish. $_ = <$fh2>; # test 13 + 2*$m ok /shared/; for (my $i = 0; $i < $m ; $i++) { $_ = <$fh2>; chomp; # test 14+2*$m .. 13+3*$m is $_, 1; } close $fh2; # Wipe the temporary file unlink $datafile; File-NFSLock-1.21/t/100_load.t0000644000076400007640000000045311607126675013653 0ustar robrob# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.t' ######################### We start with some black magic to print on failure. use strict; use warnings; use Test::More tests => 1; use_ok 'File::NFSLock'; File-NFSLock-1.21/t/410_die.t0000644000076400007640000000457411607126675013511 0ustar robrob# Lock Test with fatal error (die) use strict; use warnings; use Test::More tests => 9; use File::NFSLock; use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC LOCK_EX); $| = 1; # Buffer must be autoflushed because of fork() below. my $datafile = "testfile.dat"; # Wipe lock file in case it exists unlink ("$datafile$File::NFSLock::LOCK_EXTENSION"); # Create a blank file sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); close ($fh); # test 1 ok (-e $datafile && !-s _); # test 2 my ($rd1, $wr1); ok (pipe($rd1, $wr1)); # Connected pipe for child1 my $pid = fork; if (!$pid) { # Child #1 process # Obtain exclusive lock my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, }; print $wr1 !!$lock; # Send boolean success status down pipe close($wr1); # Signal to parent that the Blocking lock is done close($wr1); if ($lock) { sysopen(my $fh, $datafile, O_RDWR | O_TRUNC); # And then put a magic word into the file print $fh "exclusive\n"; close $fh; open(STDERR,">/dev/null"); die "I will die while lock is still aquired"; } die "Lock failed!"; } # test 3 ok 1; # Fork successful close ($wr1); # Waiting for child1 to finish its lock status my $child1_lock = <$rd1>; close ($rd1); # Report status of the child1_lock. # It should have been successful # test 4 ok ($child1_lock); # Clear the zombie # test 5 ok (wait); # test 6 my ($rd2, $wr2); ok (pipe($rd2, $wr2)); # Connected pipe for child2 if (!fork) { # The last lock died, so this should aquire fine. my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, blocking_timeout => 10, }; if ($lock) { sysopen(my $fh, $datafile, O_RDWR | O_TRUNC); # Immediately put the magic word into the file print $fh "lock2\n"; truncate ($fh, tell $fh); close $fh; } print $wr2 !!$lock; # Send boolean success status down pipe close($wr2); # Signal to parent that the Blocking lock is done close($rd2); exit; # Release this new lock } # test 7 ok 1; # Fork successful close ($wr2); # Waiting for child2 to finish its lock status my $child2_lock = <$rd2>; close ($rd2); # Report status of the child2_lock. # This should have been successful. # test 8 ok ($child2_lock); # Load up whatever the file says now sysopen(my $fh2, $datafile, O_RDONLY); $_ = <$fh2>; # test 9 ok /lock2/; close $fh2; # Wipe the temporary file unlink $datafile; File-NFSLock-1.21/t/420_crash.t0000644000076400007640000000476111607126675014047 0ustar robrob# Lock Test with abnormal or abrupt termination (System crash or SIGKILL) use strict; use warnings; use Test::More tests => 10; use File::NFSLock; use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC LOCK_EX); $| = 1; # Buffer must be autoflushed because of fork() below. my $datafile = "testfile.dat"; # Wipe lock file in case it exists unlink ("$datafile$File::NFSLock::LOCK_EXTENSION"); # Create a blank file sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); close ($fh); # test 1 ok (-e $datafile && !-s _); # test 2 my ($rd1, $wr1); ok (pipe($rd1, $wr1)); # Connected pipe for child1 my $pid = fork; if (!$pid) { # Child #1 process # Obtain exclusive lock my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, }; open(STDERR,">/dev/null"); print $wr1 !!$lock; # Send boolean success status down pipe close($wr1); # Signal to parent that the Blocking lock is done close($rd1); if ($lock) { sleep 10; # hold the lock for a moment sysopen(my $fh, $datafile, O_RDWR | O_TRUNC); # And then put a magic word into the file print $fh "exclusive\n"; close $fh; } exit; } # test 3 ok 1; # Fork successful close ($wr1); # Waiting for child1 to finish its lock status my $child1_lock = <$rd1>; close ($rd1); # Report status of the child1_lock. # It should have been successful # test 4 ok ($child1_lock); # Pretend like the box crashed rudely while the lock is aquired # test 5 ok (kill "KILL", $pid); # Clear the zombie # test 6 ok (wait); # test 7 my ($rd2, $wr2); ok (pipe($rd2, $wr2)); # Connected pipe for child2 if (!fork) { # The last lock died, so this should aquire fine. my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, blocking_timeout => 10, }; if ($lock) { sysopen(my $fh, $datafile, O_RDWR | O_TRUNC); # Immediately put the magic word into the file print $fh "lock2\n"; truncate ($fh, tell $fh); close $fh; } print $wr2 !!$lock; # Send boolean success status down pipe close($wr2); # Signal to parent that the Blocking lock is done close($rd2); exit; # Release this new lock } # test 8 ok 1; # Fork successful close ($wr2); # Waiting for child2 to finish its lock status my $child2_lock = <$rd2>; close ($rd2); # Report status of the child2_lock. # This should have been successful. # test 9 ok ($child2_lock); # Load up whatever the file says now sysopen(my $fh2, $datafile, O_RDONLY); $_ = <$fh2>; # test 10 ok /lock2/; close $fh2; # Wipe the temporary file unlink $datafile; File-NFSLock-1.21/t/210_nb_ex.t0000644000076400007640000000425211607126675014032 0ustar robrobuse strict; use warnings; # Non-Blocking Exclusive Lock Test use Test::More tests => 8; use File::NFSLock; use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC LOCK_EX LOCK_NB); $| = 1; # Buffer must be autoflushed because of fork() below. my $datafile = "testfile.dat"; # Create a blank file sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); close ($fh); ok (-e $datafile && !-s _); my ($rd1,$wr1); ok (pipe($rd1,$wr1)); # Connected pipe for child1 if (!fork) { # Child #1 process my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX | LOCK_NB, }; print $wr1 !!$lock; # Send boolean success status down pipe close($wr1); # Signal to parent that the Non-Blocking lock is done close($rd1); if ($lock) { sleep 2; # hold the lock for a moment sysopen(my $fh, $datafile, O_RDWR); # now put a magic word into the file print $fh "child1\n"; close $fh; } exit; } ok 1; # Fork successful close ($wr1); # Waiting for child1 to finish its lock status my $child1_lock = <$rd1>; close ($rd1); # Report status of the child1_lock. # It should have been successful ok ($child1_lock); my ($rd2, $wr2); ok (pipe($rd2,$wr2)); # Connected pipe for child2 if (!fork) { # Child #2 process my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX | LOCK_NB, }; print $wr2 !!$lock; # Send boolean success status down pipe close($wr2); # Signal to parent that the Non-Blocking lock is done close($rd2); if ($lock) { sysopen(my $fh, $datafile, O_RDWR); # now put a magic word into the file print $fh "child2\n"; close $fh; } exit; } ok 1; # Fork successful close ($wr2); # Waiting for child2 to finish its lock status my $child2_lock = <$rd2>; close ($rd2); # Report status of the child2_lock. # This lock should not have been obtained since # the child1 lock should still have been established. ok (!$child2_lock); # Wait until the children have finished. wait; wait; # Load up whatever the file says now sysopen(my $fh2, $datafile, O_RDONLY); $_ = <$fh2>; close $fh2; # It should be child1 if it was really nonblocking # since it got the lock first. ok /child1/; # Wipe the temporary file unlink $datafile; File-NFSLock-1.21/t/120_single.t0000644000076400007640000000172311607126675014220 0ustar robrob# Blocking Exclusive test within a single process (no fork) use Test::More tests => 2; use File::NFSLock; use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC LOCK_EX); my $datafile = "testfile.dat"; # Create a blank file sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); close ($fh); ok (-e $datafile && !-s _); # Wipe any old stale locks unlink "$datafile$File::NFSLock::LOCK_EXTENSION"; # Single process trying to count to $n my $n = 20; for (my $i = 0; $i < $n ; $i++) { my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, }; sysopen(my $fh, $datafile, O_RDWR); # Read the current value my $count = <$fh>; # Increment it $count ++; # And put it back seek ($fh,0,0); print $fh "$count\n"; close $fh; } # Load up whatever the file says now sysopen($fh, $datafile, O_RDONLY); $_ = <$fh>; close $fh; chomp; # It should be the same as the number of times it looped is $n, $_; # Wipe the temporary file unlink $datafile; File-NFSLock-1.21/t/230_double.t0000644000076400007640000000216211607126675014211 0ustar robrob# Exclusive Double Lock Test # # This tests to make sure the same process can aquire # an exclusive lock multiple times for the same file. use strict; use warnings; use Test::More tests => 5; use File::NFSLock; use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC O_APPEND LOCK_EX LOCK_SH LOCK_NB); $| = 1; my $datafile = "testfile.dat"; # Wipe lock file in case it exists unlink ("$datafile$File::NFSLock::LOCK_EXTENSION"); # Create a blank file sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); close ($fh); ok (-e $datafile && !-s _); my $lock1 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, blocking_timeout => 10, }; ok ($lock1); sysopen(my $fh2, $datafile, O_RDWR | O_APPEND); print $fh2 "lock1\n"; close $fh2; my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, blocking_timeout => 10, }; ok ($lock2); sysopen(my $fh3, $datafile, O_RDWR | O_APPEND); print $fh3 "lock2\n"; close $fh3; # Load up whatever the file says now sysopen(my $fh4, $datafile, O_RDONLY); $_ = <$fh4>; ok /lock1/; $_ = <$fh4>; ok /lock2/; close $fh4; # Wipe the temporary file unlink $datafile; File-NFSLock-1.21/t/400_kill.t0000644000076400007640000000471511607126675013677 0ustar robrob# Lock Test with graceful termination (SIGTERM or SIGINT) use strict; use warnings; use Test::More tests => 10; use File::NFSLock; use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC LOCK_EX); $| = 1; # Buffer must be autoflushed because of fork() below. my $datafile = "testfile.dat"; # Wipe lock file in case it exists unlink ("$datafile$File::NFSLock::LOCK_EXTENSION"); # Create a blank file sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); close ($fh); # test 1 ok (-e $datafile && !-s _); # test 2 my ($rd1, $wr1); ok (pipe($rd1, $wr1)); # Connected pipe for child1 my $pid = fork; if (!$pid) { # Child #1 process # Obtain exclusive lock my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, }; open(STDERR,">/dev/null"); print $wr1 !!$lock; # Send boolean success status down pipe close($wr1); # Signal to parent that the Blocking lock is done close($rd1); if ($lock) { sleep 10; # hold the lock for a moment sysopen(my $fh, $datafile, O_RDWR | O_TRUNC); # And then put a magic word into the file print $fh "exclusive\n"; close $fh; } exit; } # test 3 ok 1; # Fork successful close ($wr1); # Waiting for child1 to finish its lock status my $child1_lock = <$rd1>; close ($rd1); # Report status of the child1_lock. # It should have been successful # test 4 ok ($child1_lock); # Pretend like the locked process hit CTRL-C # test 5 ok (kill "INT", $pid); # Clear the zombie # test 6 ok (wait); # test 7 my ($rd2, $wr2); ok (pipe($rd2, $wr2)); # Connected pipe for child2 if (!fork) { # The last lock died, so this should aquire fine. my $lock = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, blocking_timeout => 10, }; if ($lock) { sysopen(my $fh, $datafile, O_RDWR | O_TRUNC); # Immediately put the magic word into the file print $fh "lock2\n"; truncate ($fh, tell $fh); close $fh; } print $wr2 !!$lock; # Send boolean success status down pipe close($wr2); # Signal to parent that the Blocking lock is done close($rd2); exit; # Release this new lock } # test 8 ok 1; # Fork successful close ($wr2); # Waiting for child2 to finish its lock status my $child2_lock = <$rd2>; close ($rd2); # Report status of the child2_lock. # This should have been successful. # test 9 ok ($child2_lock); # Load up whatever the file says now sysopen(my $fh2, $datafile, O_RDONLY); $_ = <$fh2>; # test 10 ok /lock2/; close $fh2; # Wipe the temporary file unlink $datafile; File-NFSLock-1.21/MANIFEST0000644000076400007640000000103411607416245013044 0ustar robrobChanges Module History MANIFEST This file Makefile.PL Makefile script README What it says lib/File/NFSLock.pm Main module File-NFSLock.spec Spec for RPM File-NFSLock.spec.PL Spec generator examples/lock_test Script used to test on live system t/100_load.t t/110_compare.t t/120_single.t t/200_bl_ex.t t/210_nb_ex.t t/220_ex_scope.t t/230_double.t t/240_fork.t t/300_bl_sh.t t/400_kill.t t/410_die.t t/420_crash.t META.yml Module meta-data (added by MakeMaker) File-NFSLock-1.21/File-NFSLock.spec.PL0000644000076400007640000000603311607126675015226 0ustar robrob# Copyright (C) 2002 Rob Brown (bbb@cpan.org) # Generic rpm SPEC file generator. use strict; my $p = $1 if $0 =~ m%([^/]*)$%; my $output = shift or die "create what?"; ### Extract $VERSION from VERSION_FROM my $name; my $version; $INC{"ExtUtils/MakeMaker.pm"} = 1; sub WriteMakefile { my %props = @_; $name = $props{NAME} || die "Makefile.PL: Missing NAME"; if ($version = $props{VERSION}) { # done } elsif (my $version_from = $props{VERSION_FROM}) { $@ = ""; $version = eval qq{ do "$version_from"; \$$name\::VERSION || die "$version_from: Missing VERSION"; }; die $@ if $@; if (!defined $version) { die "$version_from: Missing VERSION"; } } else { die "Makefile.PL: Could not determine version!"; } } do "Makefile.PL"; if ($name) { $name =~ s/::/-/g; } else { die "Makefile.PL: Missing WriteMakefile"; } $version || die "No version!"; my ($class,$subclass) = split(/\-/,$name,2); local $/ = undef; $_ = ; s/\@CLASS\@/$class/g; s/\@SUBCLASS\@/$subclass/g; s/\@VERSION\@/$version/g; open SPEC, ">$output" or die "$output: $!"; print SPEC "# Automatically generated by $p\n"; print SPEC $_; close SPEC; __DATA__ %define class @CLASS@ %define subclass @SUBCLASS@ %define version @VERSION@ %define release 1 %define defperlver 5.6.1 # Derived values %define real_name %{class}-%{subclass} %define name perl-%{real_name} %define perlver %(rpm -q perl --queryformat '%%{version}' 2> /dev/null || echo %{defperlver}) # Provide perl-specific find-{provides,requires}. %define __find_provides %( echo -n /usr/lib/rpm/find-provides && [ -x /usr/lib/rpm/find-provides.perl ] && echo .perl ) %define __find_requires %( echo -n /usr/lib/rpm/find-requires && [ -x /usr/lib/rpm/find-requires.perl ] && echo .perl ) Summary: Perl module %{class}::%{subclass} Name: %{name} Version: %{version} Release: %{release} Group: Development/Perl License: Artistic Source: http://www.cpan.org./modules/by-module/%{class}/%{real_name}-%{version}.tar.gz URL: http://search.cpan.org/search?dist=%{real_name} Vendor: Rob Brown Packager: Rob Brown BuildRequires: perl BuildArch: noarch BuildRoot: %{_tmppath}/%{name}-%{version}-buildroot-%(id -u -n) Requires: perl = %{perlver} Provides: %{real_name} = %{version} %description %{class}::%{subclass} Perl Module %prep %setup -q -n %{real_name}-%{version} %build %{__perl} Makefile.PL %{__make} OPTIMIZE="$RPM_OPT_FLAGS" %install rm -rf $RPM_BUILD_ROOT %{makeinstall} PREFIX=$RPM_BUILD_ROOT%{_prefix} [ -x /usr/lib/rpm/brp-compress ] && /usr/lib/rpm/brp-compress # Clean up some files we don't want/need rm -rf `find $RPM_BUILD_ROOT -name "perllocal.pod" -o -name ".packlist" -o -name "*.bs"` find $RPM_BUILD_ROOT%{_prefix} -type d | tac | xargs rmdir --ign %clean rm -rf $RPM_BUILD_ROOT HERE=`pwd` cd .. rm -rf $HERE %files %defattr(-,root,root) %doc README Changes examples %{_prefix} %changelog * Thu May 30 2002 Rob Brown - initial creation File-NFSLock-1.21/Makefile.PL0000644000076400007640000000165711607126675013705 0ustar robrobuse ExtUtils::MakeMaker; WriteMakefile NAME => "File::NFSLock", AUTHOR => "Paul Seamons", ABSTRACT_FROM => "lib/File/NFSLock.pm", VERSION_FROM => "lib/File/NFSLock.pm", PREREQ_PM => { # e.g., 'Module::Name' => 1.1 }, dist => { DIST_DEFAULT => 'all tardist', COMPRESS => 'gzip -vf', SUFFIX => '.gz', }, clean => { FILES => '*~', }, realclean => { FILES => '*~', }, ; package MY; sub processPL { my $self = shift; my $block = $self->SUPER::processPL(@_); # "Version:" in spec needs to match # "$VERSION" from VERSION_FROM $block =~ s%(spec.PL\s*)$%$1 \$\(VERSION_FROM\)%m; $block; } sub libscan { my $self = shift; my $path = shift; ($path =~ / \bCVS\b | \~$ /x) ? undef : $path; } sub postamble { return qq^ pm_to_blib: README README: \$(VERSION_FROM) pod2text \$(VERSION_FROM) > README ^; } 1; File-NFSLock-1.21/examples/0000755000076400007640000000000011607446326013536 5ustar robrobFile-NFSLock-1.21/examples/lock_test0000755000076400007640000000166611607126675015466 0ustar robrob#!/usr/bin/perl -w ### Written by Rob Brown ### This script is designed to be ran on multiple boxes ### by multiple processes with a high increment number. ### The processes should all compete, but a successful ### test occurs if all of the specified inc's add up to ### the final number in the specified file. use strict; use File::NFSLock (); use Fcntl qw(O_RDWR O_CREAT LOCK_EX); my $datafile = shift; my $inc = shift || do { print "Usage: $0 \n"; exit; }; while ( $inc -- > 0 ) { my $lock = new File::NFSLock ($datafile, LOCK_EX) or print "Ouch1\n"; # blocking lock (Exclusive) sysopen(FH, $datafile, O_RDWR | O_CREAT) or die "Cannot open [$datafile][$!]"; ### read the count and spit it out my $count = ; $count ++; print "[$$] I win with [$count] \r"; seek (FH,0,0); print FH "$count\n"; close FH; # $lock leaves scope and unlocks automagically } print "\n\n"; File-NFSLock-1.21/File-NFSLock.spec0000644000076400007640000000363511607446267014723 0ustar robrob# Automatically generated by File-NFSLock.spec.PL %define class File %define subclass NFSLock %define version 1.21 %define release 1 %define defperlver 5.6.1 # Derived values %define real_name %{class}-%{subclass} %define name perl-%{real_name} %define perlver %(rpm -q perl --queryformat '%%{version}' 2> /dev/null || echo %{defperlver}) # Provide perl-specific find-{provides,requires}. %define __find_provides %( echo -n /usr/lib/rpm/find-provides && [ -x /usr/lib/rpm/find-provides.perl ] && echo .perl ) %define __find_requires %( echo -n /usr/lib/rpm/find-requires && [ -x /usr/lib/rpm/find-requires.perl ] && echo .perl ) Summary: Perl module %{class}::%{subclass} Name: %{name} Version: %{version} Release: %{release} Group: Development/Perl License: Artistic Source: http://www.cpan.org./modules/by-module/%{class}/%{real_name}-%{version}.tar.gz URL: http://search.cpan.org/search?dist=%{real_name} Vendor: Rob Brown Packager: Rob Brown BuildRequires: perl BuildArch: noarch BuildRoot: %{_tmppath}/%{name}-%{version}-buildroot-%(id -u -n) Requires: perl = %{perlver} Provides: %{real_name} = %{version} %description %{class}::%{subclass} Perl Module %prep %setup -q -n %{real_name}-%{version} %build %{__perl} Makefile.PL %{__make} OPTIMIZE="$RPM_OPT_FLAGS" %install rm -rf $RPM_BUILD_ROOT %{makeinstall} PREFIX=$RPM_BUILD_ROOT%{_prefix} [ -x /usr/lib/rpm/brp-compress ] && /usr/lib/rpm/brp-compress # Clean up some files we don't want/need rm -rf `find $RPM_BUILD_ROOT -name "perllocal.pod" -o -name ".packlist" -o -name "*.bs"` find $RPM_BUILD_ROOT%{_prefix} -type d | tac | xargs rmdir --ign %clean rm -rf $RPM_BUILD_ROOT HERE=`pwd` cd .. rm -rf $HERE %files %defattr(-,root,root) %doc README Changes examples %{_prefix} %changelog * Thu May 30 2002 Rob Brown - initial creation File-NFSLock-1.21/Changes0000644000076400007640000000671711607416110013212 0ustar robrobRevision history for Perl extension File::NFSLock. 1.21 Jul 13 17:00 2011 - Various patches by Chorny at cpan dot org and fREW frioux at gmail dot com: - Windows NTFS compatibility fixes. - Allow PID to be negative. - Lexically scope temp file handles to reduce changes of memory leak and avoid unintentional glob clobberation. - Security fix: 3 arg open(). - Repair test suites logics. - Fixed infinite freezing on Strawberry Perl v5.10.0. - Fixed infinite freezing on ActiveState Perl v5.12.1. - Sorry for the past 8 years of suffering. 1.20 May 13 12:00 2003 - Avoid double reverting signal handlers when unlock() is explicitly called instead of implicitly called from DESTROY(). - Fixed this warning: Argument "DEFAULT" isn't numeric in numeric eq (==) 1.19 Dec 17 23:30 2002 - Minor code cleanup patch by Stephen Waters. 1.18 Jul 25 17:00 2002 - Add newpid() method to handle fork() conditions. 1.17 Jun 10 12:00 2002 - Handle system crash recovery better or other abnormal/abrupt termination (like SIGKILL) conditions more gracefully. 1.16 Jun 05 15:00 2002 - Allow exclusive lock to be obtained on the same file multiple times by the the same process. 1.15 Jun 04 09:00 2002 - Default to catch certain signals to avoid creating stale locks on graceful termination. - More tests to test signal handlers. - Fix test t/300_bl_sh.t to measure only what is required. 1.14 Jun 03 12:00 2002 - Add test to exploit unlock bug (fixed by Andy in 1.13) - Less anal tests for slower platforms (Slowaris) to succeed as well. 1.13 May 30 12:00 2002 - Add spec file for RPM packaging. - Show example in perldoc using numerical constants. - Make perldoc example strict clean. - Add INSTALL section to perldoc. - Fixed bug that forced a lock aquired by another process to be released when an exclusive lock attempt fails. Patch by andyh@myinternet.com.au (Andy Hird) 1.12 Nov 05 12:00 2001 - Change code to utilize numerical constants instead of the magic strings. - Change several sub routines into methods of the object to reduce arguments passed. - Avoid double unlocking (DESTROY). - Added some nice tests. - Pulled out stale_lock code to check once at initial lock attempt instead of repeated checks during the blocking lock loop. This may change functionality slightly in that a lock will never "become" stale if it wasn't already stale when the lock attempt initiated. - Shared lock feature now functional. 1.11 Oct 30 12:00 2001 - (Not released) - Initial attempt to add shared lock feature. 1.10 Jul 31 10:10 2001 - Allow for numerical constants from Fcntl. - Return Error status in $errstr. - Allow for custom lock extensions via $LOCK_EXTENSION. - Allow for passing parameters as a hashref - Allow for stale_lock_timeout parameter 1.00 May 24 10:50 2001 - Initial release of File::NFSLock. - Release under 1.00 tag as this is already in use. - Blocking and Nonblocking locking is possible. - uncache routine is available.