File-NFSLock-1.27/000755 000765 000024 00000000000 12430737642 013514 5ustar00robstaff000000 000000 File-NFSLock-1.27/Changes000644 000765 000024 00000011621 12430737375 015013 0ustar00robstaff000000 000000 Revision history for Perl extension File::NFSLock. 1.27 Nov 12 13:00 2014 - RT#99431: - More Win32 compatibility fixes in test suite. - RT#48102: - Add tests for new ->fork() method. 1.26 Nov 07 16:00 2014 - Add File::NFSLock->fork() convenience method. - RT#48102 Report by Todd Foggoa: - More gracefully handle fork() to behave like Linux by sharing the lock between both parent and child processes when ->newpid() is called. 1.25 Jul 30 14:00 2014 - RT#99431 Report by Nathan Glenn: - Fixed tempfile syntax by Christian Walde. - Fixed Win32 Shared Lock by Christian Walde. - RT#42122 Report by converter at cpan.org: - Add tests to help debug Taint issues 1.24 Jul 30 14:00 2014 - Fixed a race condition in crash recovery. - RT#88520 Thanks David Steinbrunner: Fix typos 1.23 Jul 28 11:00 2014 - More gracefully handle arbitrary hostnames. - Patch RT#84658 by Yann Rouillard: - Avoid gleefully double removing valid lockfile when ->unlock is explicitly called. - Patch RT#61258 by cpan at danonline.net: - Fixed $graceful_sig to exit with non-zero to more closely match stock signal handlers. 1.22 Jul 26 09:00 2014 - Reported by Kent Fredric and Karen Etheridge: - Patch RT#86125 and RT#91546 - Use File::Temp for concurrency compatibility in test suite, such as HARNESS_OPTIONS=j20 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. File-NFSLock-1.27/File-NFSLock.spec000644 000765 000024 00000003635 12430737414 016510 0ustar00robstaff000000 000000 # Automatically generated by File-NFSLock.spec.PL %define class File %define subclass NFSLock %define version 1.27 %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.27/File-NFSLock.spec.PL000644 000765 000024 00000006033 12341707146 017015 0ustar00robstaff000000 000000 # 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.27/MANIFEST000644 000765 000024 00000001253 12430737642 014646 0ustar00robstaff000000 000000 Changes 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/130_taint.t t/200_bl_ex.t t/210_nb_ex.t t/220_ex_scope.t t/230_double.t t/240_fork_ex.t t/241_fork_ex.t t/242_fork_ex.t t/243_fork_ex.t t/250_fork_sh.t t/251_fork_sh.t t/252_fork_sh.t t/253_fork_sh.t t/300_bl_sh.t t/400_kill.t t/410_die.t t/420_crash.t t/430_taint.t META.yml Module meta-data (added by MakeMaker) File-NFSLock-1.27/META.yml000644 000765 000024 00000001012 12430737642 014757 0ustar00robstaff000000 000000 --- #YAML:1.0 name: File-NFSLock version: 1.27 abstract: perl module to do NFS (or not) locking author: - Paul Seamons license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: {} no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 File-NFSLock-1.27/Makefile.PL000644 000765 000024 00000001657 12341707146 015474 0ustar00robstaff000000 000000 use 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.27/README000644 000765 000024 00000021706 12430163172 014371 0ustar00robstaff000000 000000 NAME 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 acquired. 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. fork my $pid = $lock->fork; if (!defined $pid) { # Fork Failed } elsif ($pid) { # Parent ... } else { # Child ... } fork() is a convenience method that acts just like the normal CORE::fork() except it safely ensures the lock is retained within both parent and child processes. WITHOUT this, then when either the parent or child process releases the lock, then the entire lock will be lost, allowing external processes to re-acquire a lock on the same file, even if the other process still has the lock object in scope. This can cause corruption since both processes might think they have exclusive access to the file. newpid my $pid = fork; if (!defined $pid) { # Fork Failed } elsif ($pid) { $lock->newpid; # Parent ... } else { $lock->newpid; # Child ... } The newpid() synopsis shown above is equivalent to the one used for the fork() method, but it's not intended to be called directly. It is called internally by the fork() method. To be safe, it is recommended to use $lock->fork() from now on. 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 extension 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). REPO The source is now on github: git clone https://github.com/hookbot/File-NFSLock BUGS If you spot anything, please submit a pull request on github and/or submit a ticket with RT: https://rt.cpan.org/Dist/Display.html?Queue=File-NFSLock 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-2014, 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.27/examples/000755 000765 000024 00000000000 12430737642 015332 5ustar00robstaff000000 000000 File-NFSLock-1.27/lib/000755 000765 000024 00000000000 12430737642 014262 5ustar00robstaff000000 000000 File-NFSLock-1.27/t/000755 000765 000024 00000000000 12430737642 013757 5ustar00robstaff000000 000000 File-NFSLock-1.27/t/100_load.t000644 000765 000024 00000000510 12364743120 015431 0ustar00robstaff000000 000000 # 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 File::Temp qw(tempfile); use_ok 'File::NFSLock'; File-NFSLock-1.27/t/110_compare.t000644 000765 000024 00000000464 11607126675 016162 0ustar00robstaff000000 000000 use 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.27/t/120_single.t000644 000765 000024 00000001774 12430163602 016005 0ustar00robstaff000000 000000 # 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); use File::Temp qw(tempfile); my $datafile = (tempfile 'XXXXXXXXXX')[1]; # 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.27/t/130_taint.t000644 000765 000024 00000002034 12430163530 015632 0ustar00robstaff000000 000000 #!/usr/bin/perl -T -w # Blocking Exclusive test within a single process with Taint enabled use Test::More tests => 2; use File::NFSLock; use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC LOCK_EX); use File::Temp qw(tempfile); my $datafile = (tempfile 'XXXXXXXXXX')[1]; # 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.27/t/200_bl_ex.t000644 000765 000024 00000002614 12430163602 015606 0ustar00robstaff000000 000000 # Blocking Exclusive Lock Test use strict; use warnings; use File::Temp qw(tempfile); 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 = (tempfile 'XXXXXXXXXX')[1]; # 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.27/t/210_nb_ex.t000644 000765 000024 00000004323 12430163602 015610 0ustar00robstaff000000 000000 use strict; use warnings; use File::Temp qw(tempfile); # 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 = (tempfile 'XXXXXXXXXX')[1]; # 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.27/t/220_ex_scope.t000644 000765 000024 00000007216 12430163602 016327 0ustar00robstaff000000 000000 # 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 File::Temp qw(tempfile); 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 = (tempfile 'XXXXXXXXXX')[1]; # 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.27/t/230_double.t000644 000765 000024 00000002234 12430163602 015770 0ustar00robstaff000000 000000 # Exclusive Double Lock Test # # This tests to make sure the same process can acquire # an exclusive lock multiple times for the same file. use strict; use warnings; use File::Temp qw(tempfile); 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 = (tempfile 'XXXXXXXXXX')[1]; # 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.27/t/240_fork_ex.t000644 000765 000024 00000003621 12430163602 016155 0ustar00robstaff000000 000000 # Exclusive Fork Test # # This tests the capabilities of fork after lock to # ensure child retains exclusive lock even if parent releases it. use strict; use warnings; use File::Temp qw(tempfile); use Test::More tests => 6; 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 _); { # 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; # Both parent and child must unlock # before the lock is truly released. $lock1->newpid; } } # Lock is out of scope, but should # still be acquired by the child. # 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. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok (!$lock2); } # Wait for child to finish ok(wait); # Try again now that the child is done. # This time it should work. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok($lock2); } # Wipe the temporary file unlink $datafile; File-NFSLock-1.27/t/241_fork_ex.t000644 000765 000024 00000004547 12430163602 016166 0ustar00robstaff000000 000000 # Exclusive Fork Test # # This tests the capabilities of fork after lock to # ensure parent retains exclusive lock even if child releases it. use strict; use warnings; use File::Temp qw(tempfile); use Test::More tests => 6; 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 _); pipe(my $dad_rd, my $dad_wr); { # 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 # Fork worked ok 1; # Let go of the other side $dad_rd close $dad_wr; # Test possible race condition # by making parent reach newpid() # and attempt relock before child # even calls newpid() the first time. sleep 2; $lock1->newpid; # Child continues on while parent holds onto the lock... } else { # Parent process # Notify lock that we've forked. $lock1->newpid; # Parent hangs onto the lock for a bit sleep 5; # Parent finally releases the lock undef $lock1; # And releases $dad_rd to signal the child # that's the lock should be free. close $dad_wr; # Clear the Child Zombie wait; # Avoid normal "exit" checking plan counts. require POSIX; POSIX::_exit(0); # Don't continue on since the child should have already done the tests. } } # Lock is out of scope, but should # still be acquired by the parent. # Try to get a non-blocking lock. # Quickly, before the parent releases it. # This lock should fail. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok(!$lock2); } # Wait for the parent process to release the lock scalar <$dad_rd>; ok(1); # Try again now that the parent is done. # This time it should work. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok($lock2); } # Wipe the temporary file unlink $datafile; File-NFSLock-1.27/t/242_fork_ex.t000644 000765 000024 00000003342 12430163602 016157 0ustar00robstaff000000 000000 # Exclusive Fork Test # # This tests the capabilities of fork after lock to # ensure child retains exclusive lock even if parent releases it. # This test uses ->fork() instead of ->newpid() use strict; use warnings; use File::Temp qw(tempfile); use Test::More tests => 6; 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 _); { # Forced dummy scope my $lock1 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, }; ok ($lock1); my $pid = $lock1->fork; if (!defined $pid) { die "fork failed!"; } elsif (!$pid) { # Child process # Act busy for a while sleep 5; # Now release lock exit; } else { # Fork worked ok 1; # Leaving scope should release only the parent side } } # Lock is out of scope, but should # still be acquired by the child. # 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. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok (!$lock2); } # Wait for child to finish ok(wait); # Try again now that the child is done. # This time it should work. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok($lock2); } # Wipe the temporary file unlink $datafile; File-NFSLock-1.27/t/243_fork_ex.t000644 000765 000024 00000004252 12430163602 016161 0ustar00robstaff000000 000000 # Exclusive Fork Test # # This tests the capabilities of fork after lock to # ensure parent retains exclusive lock even if child releases it. # This test uses ->fork() instead of ->newpid() use strict; use warnings; use File::Temp qw(tempfile); use Test::More tests => 6; 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 _); pipe(my $dad_rd, my $dad_wr); { # Forced dummy scope my $lock1 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX, }; ok ($lock1); my $pid = $lock1->fork; if (!defined $pid) { die "fork failed!"; } elsif (!$pid) { # Child process # Fork worked ok 1; # Let go of the other side $dad_rd close $dad_wr; # Child continues on while parent holds onto the lock... } else { # Parent process # Parent hangs onto the lock for a bit sleep 5; # Parent finally releases the lock undef $lock1; # And releases $dad_rd to signal the child # that's the lock should be free. close $dad_wr; # Clear the Child Zombie wait; # Avoid normal "exit" checking plan counts. require POSIX; POSIX::_exit(0); # Don't continue on since the child should have already done the tests. } } # Lock is out of scope, but should # still be acquired by the parent. # Try to get a non-blocking lock. # Quickly, before the parent releases it. # This lock should fail. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok(!$lock2); } # Wait for the parent process to release the lock scalar <$dad_rd>; ok(1); # Try again now that the parent is done. # This time it should work. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok($lock2); } # Wipe the temporary file unlink $datafile; File-NFSLock-1.27/t/250_fork_sh.t000644 000765 000024 00000003613 12430163602 016155 0ustar00robstaff000000 000000 # Shared Fork Test # # This tests the capabilities of fork after lock to # ensure child retains shared lock even if parent releases it. use strict; use warnings; use File::Temp qw(tempfile); use Test::More tests => 6; 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 _); { # Forced dummy scope my $lock1 = new File::NFSLock { file => $datafile, lock_type => LOCK_SH, }; 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; # Both parent and child must unlock # before the lock is truly released. $lock1->newpid; } } # Lock is out of scope, but should # still be acquired by the child. # 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. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok (!$lock2); } # Wait for child to finish ok(wait); # Try again now that the child is done. # This time it should work. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok($lock2); } # Wipe the temporary file unlink $datafile; File-NFSLock-1.27/t/251_fork_sh.t000644 000765 000024 00000004542 12430163602 016160 0ustar00robstaff000000 000000 # Shared Fork Test # # This tests the capabilities of fork after lock to # ensure parent retains shared lock even if child releases it. use strict; use warnings; use File::Temp qw(tempfile); use Test::More tests => 6; 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 _); pipe(my $dad_rd, my $dad_wr); { # Forced dummy scope my $lock1 = new File::NFSLock { file => $datafile, lock_type => LOCK_SH, }; ok ($lock1); my $pid = fork; if (!defined $pid) { die "fork failed!"; } elsif (!$pid) { # Child process # Fork worked ok 1; # Let go of the other side $dad_rd close $dad_wr; # Test possible race condition # by making parent reach newpid() # and attempt relock before child # even calls newpid() the first time. sleep 2; $lock1->newpid; # Child continues on while parent holds onto the lock... } else { # Parent process # Notify lock that we've forked. $lock1->newpid; # Parent hangs onto the lock for a bit sleep 5; # Parent finally releases the lock undef $lock1; # And releases $dad_rd to signal the child # that's the lock should be free. close $dad_wr; # Clear the Child Zombie wait; # Avoid normal "exit" checking plan counts. require POSIX; POSIX::_exit(0); # Don't continue on since the child should have already done the tests. } } # Lock is out of scope, but should # still be acquired by the parent. # Try to get a non-blocking lock. # Quickly, before the parent releases it. # This lock should fail. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok (!$lock2); } # Wait for the parent process to release the lock scalar <$dad_rd>; ok(1); # Try again now that the parent is done. # This time it should work. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok($lock2); } # Wipe the temporary file unlink $datafile; File-NFSLock-1.27/t/252_fork_sh.t000644 000765 000024 00000003334 12430163602 016157 0ustar00robstaff000000 000000 # Shared Fork Test # # This tests the capabilities of fork after lock to # ensure child retains shared lock even if parent releases it. # This test uses ->fork() instead of ->newpid() use strict; use warnings; use File::Temp qw(tempfile); use Test::More tests => 6; 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 _); { # Forced dummy scope my $lock1 = new File::NFSLock { file => $datafile, lock_type => LOCK_SH, }; ok ($lock1); my $pid = $lock1->fork; if (!defined $pid) { die "fork failed!"; } elsif (!$pid) { # Child process # Act busy for a while sleep 5; # Now release lock exit; } else { # Fork worked ok 1; # Leaving scope should release only the parent side } } # Lock is out of scope, but should # still be acquired by the child. # 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. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok (!$lock2); } # Wait for child to finish ok(wait); # Try again now that the child is done. # This time it should work. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok($lock2); } # Wipe the temporary file unlink $datafile; File-NFSLock-1.27/t/253_fork_sh.t000644 000765 000024 00000004245 12430163602 016162 0ustar00robstaff000000 000000 # Shared Fork Test # # This tests the capabilities of fork after lock to # ensure parent retains shared lock even if child releases it. # This test uses ->fork() instead of ->newpid() use strict; use warnings; use File::Temp qw(tempfile); use Test::More tests => 6; 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 _); pipe(my $dad_rd, my $dad_wr); { # Forced dummy scope my $lock1 = new File::NFSLock { file => $datafile, lock_type => LOCK_SH, }; ok ($lock1); my $pid = $lock1->fork; if (!defined $pid) { die "fork failed!"; } elsif (!$pid) { # Child process # Fork worked ok 1; # Let go of the other side $dad_rd close $dad_wr; # Child continues on while parent holds onto the lock... } else { # Parent process # Parent hangs onto the lock for a bit sleep 5; # Parent finally releases the lock undef $lock1; # And releases $dad_rd to signal the child # that's the lock should be free. close $dad_wr; # Clear the Child Zombie wait; # Avoid normal "exit" checking plan counts. require POSIX; POSIX::_exit(0); # Don't continue on since the child should have already done the tests. } } # Lock is out of scope, but should # still be acquired by the parent. # Try to get a non-blocking lock. # Quickly, before the parent releases it. # This lock should fail. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok (!$lock2); } # Wait for the parent process to release the lock scalar <$dad_rd>; ok(1); # Try again now that the parent is done. # This time it should work. { # Forced dummy scope my $lock2 = new File::NFSLock { file => $datafile, lock_type => LOCK_EX|LOCK_NB, }; ok($lock2); } # Wipe the temporary file unlink $datafile; File-NFSLock-1.27/t/300_bl_sh.t000644 000765 000024 00000012501 12430163602 015601 0ustar00robstaff000000 000000 # Blocking Shared Lock Test use strict; use warnings; use File::Temp qw(tempfile); 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 # acquired 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.27/t/400_kill.t000644 000765 000024 00000004767 12430163602 015465 0ustar00robstaff000000 000000 # Lock Test with graceful termination (SIGTERM or SIGINT) use strict; use warnings; use File::Temp qw(tempfile); 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 acquire 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.27/t/410_die.t000644 000765 000024 00000004647 12430163602 015271 0ustar00robstaff000000 000000 # Lock Test with fatal error (die) use strict; use warnings; use File::Temp qw(tempfile); 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 acquired"; } 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 acquire 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.27/t/420_crash.t000644 000765 000024 00000005034 12430163602 015620 0ustar00robstaff000000 000000 # Lock Test with abnormal or abrupt termination (System crash or SIGKILL) use strict; use warnings; use File::Temp qw(tempfile); 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 acquired # 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 acquire 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.27/t/430_taint.t000644 000765 000024 00000005076 12430163364 015653 0ustar00robstaff000000 000000 #!/usr/bin/perl -T -w # Lock Test with abnormal or abrupt termination (System crash or SIGKILL) with Taint use strict; use warnings; use File::Temp qw(tempfile); 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 = (tempfile 'XXXXXXXXXX')[1]; # 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 acquired # 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 acquire 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.27/lib/File/000755 000765 000024 00000000000 12430737642 015141 5ustar00robstaff000000 000000 File-NFSLock-1.27/lib/File/NFSLock.pm000644 000765 000024 00000053702 12430155336 016737 0ustar00robstaff000000 000000 # -*- perl -*- # # File::NFSLock - bdpO - NFS compatible (safe) locking utility # # $Id: NFSLock.pm,v 1.27 2014/11/10 14:00:00 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.27'; #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 1; }; 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 =~ /^\Q$HOSTNAME\E (-?\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 =~ /^\Q$HOSTNAME\E (-?\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 acquired. 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 ){ $self->do_unlock_shared; }else{ $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); } # Child finished running newpid() and acquired shared lock # So now we're safe to continue without risk of # blowing away the lock prematurely. unless ( $self->{lock_type} & LOCK_SH ) { # If it's not already a SHared lock, then # just switch it from EXclusive to SHared # from this process's point of view. # Then the child will still hold the lock # if the parent releases it first. # (Don't chmod the lock file.) $self->{lock_type} |= LOCK_SH; } } else { # This is the new child # Fix lock_pid to the new pid. $self->{lock_pid} = $$; # We can leave the old lock_line in the lock_file # But we need to add the new lock_line for this pid. # 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}); unless ( $self->{lock_type} & LOCK_SH ) { # If it's not already a SHared lock, then # just switch it from EXclusive to SHared # from this process's point of view. # Then the parent will still hold the lock # if this child releases it first. # (Don't chmod the lock file.) $self->{lock_type} |= LOCK_SH; } # Create signal file to notify parent that # the lock_line entry has been delegated. open (my $fh, '>', "$self->{lock_file}.fork"); close($fh); } } sub fork { my $self = shift; # Store fork response. my $pid = CORE::fork(); if (defined $pid and !$self->{unlocked}) { # Fork worked and we really have a lock to deal with # So upgrade to shared lock across both parent and child $self->newpid; } # Return original fork response return $pid; } 1; =pod =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). =back =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 acquired. 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 fork my $pid = $lock->fork; if (!defined $pid) { # Fork Failed } elsif ($pid) { # Parent ... } else { # Child ... } fork() is a convenience method that acts just like the normal CORE::fork() except it safely ensures the lock is retained within both parent and child processes. WITHOUT this, then when either the parent or child process releases the lock, then the entire lock will be lost, allowing external processes to re-acquire a lock on the same file, even if the other process still has the lock object in scope. This can cause corruption since both processes might think they have exclusive access to the file. =head2 newpid my $pid = fork; if (!defined $pid) { # Fork Failed } elsif ($pid) { $lock->newpid; # Parent ... } else { $lock->newpid; # Child ... } The newpid() synopsis shown above is equivalent to the one used for the fork() method, but it's not intended to be called directly. It is called internally by the fork() method. To be safe, it is recommended to use $lock->fork() from now on. =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 extension 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 REPO The source is now on github: git clone https://github.com/hookbot/File-NFSLock =head1 BUGS If you spot anything, please submit a pull request on github and/or submit a ticket with RT: https://rt.cpan.org/Dist/Display.html?Queue=File-NFSLock =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-2014, 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.27/examples/lock_test000755 000765 000024 00000001666 12341707146 017255 0ustar00robstaff000000 000000 #!/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";