diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..2cd8582 --- /dev/null +++ b/.gitignore @@ -0,0 +1,17 @@ +blib/ +.build/ +_build/ +cover_db/ +inc/ +Build +Build.bat +.last_cover_stats +Makefile +Makefile.old +MANIFEST.bak +META.yml +MYMETA.yml +MYMETA.json +nytprof.out +pm_to_blib +*.tar.gz diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..187a4e1 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,24 @@ +branches: + except: + - /^issue\d+/ + - /^gh\d+/ +language: perl +env: + global: + - PERL_USE_UNSAFE_INC=0 + - AUTHOR_TESTING=1 + - AUTOMATED_TESTING=1 + - RELEASE_TESTING=1 +perl: + - "5.28" + - "5.26" + - "5.24" + - "5.22" + - "5.20" + - "5.18" + - "5.16" + - "5.14" + - "5.12" + - "5.10" +script: + - perl Makefile.PL && make test diff --git a/Changes b/Changes index 9d18164..054d8a9 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,65 @@ Revision history for Perl extension File::NFSLock. +1.29 Nov 01 14:00 2018 + - Avoid deprecated PERL_USE_UNSAFE_INC + +1.28 Nov 01 10:00 2018 + - Patch RT#130467 and RT#120088: + - Handle "." not in @INC + +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 diff --git a/File-NFSLock.spec b/File-NFSLock.spec index 44e1c30..fb5659b 100644 --- a/File-NFSLock.spec +++ b/File-NFSLock.spec @@ -1,7 +1,7 @@ # Automatically generated by File-NFSLock.spec.PL %define class File %define subclass NFSLock -%define version 1.20 +%define version 1.29 %define release 1 %define defperlver 5.6.1 diff --git a/File-NFSLock.spec.PL b/File-NFSLock.spec.PL index fdf9fdf..8a3f58b 100644 --- a/File-NFSLock.spec.PL +++ b/File-NFSLock.spec.PL @@ -11,29 +11,31 @@ 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"; + 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!"; } - } else { - die "Makefile.PL: Could not determine version!"; - } } -do "Makefile.PL"; +do "./Makefile.PL"; if ($name) { - $name =~ s/::/-/g; + $name =~ s/::/-/g; } else { - die "Makefile.PL: Missing WriteMakefile"; + die "Makefile.PL: Missing WriteMakefile"; } $version || die "No version!"; diff --git a/MANIFEST b/MANIFEST index cb44dc5..6f5a584 100644 --- a/MANIFEST +++ b/MANIFEST @@ -9,12 +9,21 @@ 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.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 diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..e6d8ea0 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,17 @@ +\.DS_Store +\bdiffs?\b +^MANIFEST\. +^MYMETA +^Makefile$ +~$ +\.old$ +\.bak$ +\.orig$ +\.gz$ +^\.git +^benchmark/ +^cover_db/ +^blib/ +^pm_to_blib$ +^\.travis.yml$ +^File-NFSLock-\d\.\d+/ diff --git a/Makefile.PL b/Makefile.PL index abc3381..cf871ef 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -26,22 +26,22 @@ WriteMakefile 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; + 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; + my $self = shift; + my $path = shift; + ($path =~ / \bCVS\b | \~$ /x) ? undef : $path; } sub postamble { - return qq^ + return qq^ pm_to_blib: README diff --git a/README b/README index b684529..0962448 100644 --- a/README +++ b/README @@ -119,127 +119,140 @@ PARAMETERS seconds). METHODS - After the $lock object is instantiated with new, as outlined above, - some methods may be used for additional functionality. + After the $lock object is instantiated with new, as outlined above, some + methods may be used for additional functionality. unlock + $lock->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. + 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 ... + } - $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() 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 ... + } - 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. + 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. + 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). + 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 - Notify paul@seamons.com or bbb@cpan.org if you spot anything. + 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. + 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. + 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: + Download and extract tarball before running these commands in its base + directory: - perl Makefile.PL - make - make test - make install + perl Makefile.PL + make + make test + make install - For RPM installation, download tarball before running these commands - in your _topdir: + 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 + 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. + 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. + 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 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. + 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) 2001 + Paul T Seamons + paul@seamons.com + http://seamons.com/ - Copyright (C) 2002-2003, - Rob B Brown - bbb@cpan.org + Copyright (C) 2002-2018, + 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 + This package may be distributed under the terms of either the + GNU General Public License + or the + Perl Artistic License - All rights reserved. + All rights reserved. diff --git a/lib/File/NFSLock.pm b/lib/File/NFSLock.pm index cc5604d..cb2f4ca 100644 --- a/lib/File/NFSLock.pm +++ b/lib/File/NFSLock.pm @@ -2,7 +2,7 @@ # # File::NFSLock - bdpO - NFS compatible (safe) locking utility # -# $Id: NFSLock.pm,v 1.34 2003/05/13 18:06:41 hookbot Exp $ +# $Id: NFSLock.pm,v 1.29 2018/11/01 14:00:00 bbb Exp $ # # Copyright (C) 2002, Paul T Seamons # paul@seamons.com @@ -25,25 +25,25 @@ package File::NFSLock; use strict; -use Exporter (); -use vars qw(@ISA @EXPORT_OK $VERSION $TYPES - $LOCK_EXTENSION $SHARE_BIT $HOSTNAME $errstr - $graceful_sig @CATCH_SIGS); -use Carp qw(croak confess); +use warnings; -@ISA = qw(Exporter); -@EXPORT_OK = qw(uncache); +use Carp qw(croak confess); +our $errstr; +use base 'Exporter'; +our @EXPORT_OK = qw(uncache); -$VERSION = '1.20'; +our $VERSION = '1.29'; #Get constants, but without the bloat of #use Fcntl qw(LOCK_SH LOCK_EX LOCK_NB); -sub LOCK_SH {1} -sub LOCK_EX {2} -sub LOCK_NB {4} +use constant { + LOCK_SH => 1, + LOCK_EX => 2, + LOCK_NB => 4, +}; ### Convert lock_type to a number -$TYPES = { +our $TYPES = { BLOCKING => LOCK_EX, BL => LOCK_EX, EXCLUSIVE => LOCK_EX, @@ -53,9 +53,9 @@ $TYPES = { SHARED => LOCK_SH, SH => LOCK_SH, }; -$LOCK_EXTENSION = '.NFSLock'; # customizable extension -$HOSTNAME = undef; -$SHARE_BIT = 1; +our $LOCK_EXTENSION = '.NFSLock'; # customizable extension +our $HOSTNAME = undef; +our $SHARE_BIT = 1; ###----------------------------------------------------------------### @@ -63,10 +63,10 @@ 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; + exit 1; }; -@CATCH_SIGS = qw(TERM INT); +our @CATCH_SIGS = qw(TERM INT); sub new { $errstr = undef; @@ -107,7 +107,7 @@ sub new { ### need the hostname if( !$HOSTNAME ){ require Sys::Hostname; - $HOSTNAME = &Sys::Hostname::hostname(); + $HOSTNAME = Sys::Hostname::hostname(); } ### quick usage check @@ -160,8 +160,9 @@ sub new { ### 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}") ){ + open ($fh,'+<', $self->{lock_file}) ){ my @mine = (); my @them = (); @@ -170,8 +171,8 @@ sub new { 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+) /) { + while(defined(my $line=<$fh>)){ + if ($line =~ /^\Q$HOSTNAME\E (-?\d+) /) { my $pid = $1; if ($pid == $$) { # This is me. push @mine, $line; @@ -198,10 +199,10 @@ sub new { ### Rescan in case lock contents were modified between time stale lock ### was discovered and lockfile lock was acquired. - seek (_FH, 0, 0); + seek ($fh, 0, 0); my $content = ''; - while(defined(my $line=<_FH>)){ - if ($line =~ /^$HOSTNAME (\d+) /) { + 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 } @@ -210,18 +211,18 @@ sub new { ### Save any valid locks or wipe file. if( length($content) ){ - seek _FH, 0, 0; - print _FH $content; - truncate _FH, length($content); - close _FH; + seek $fh, 0, 0; + print $fh $content; + truncate $fh, length($content); + close $fh; }else{ - close _FH; + close $fh; unlink $self->{lock_file}; } ### No "dead" or stale locks found. } else { - close _FH; + close $fh; } ### If attempting to acquire the same type of lock @@ -257,7 +258,7 @@ sub new { ### clear up the NFS cache $self->uncache; - ### Yes, the lock has been aquired. + ### Yes, the lock has been acquired. delete $self->{unlocked}; return $self; @@ -272,9 +273,9 @@ sub unlock ($) { if (!$self->{unlocked}) { unlink( $self->{rand_file} ) if -e $self->{rand_file}; if( $self->{lock_type} & LOCK_SH ){ - return $self->do_unlock_shared; + $self->do_unlock_shared; }else{ - return $self->do_unlock; + $self->do_unlock; } $self->{unlocked} = 1; foreach my $signal (@CATCH_SIGS) { @@ -308,10 +309,9 @@ sub create_magic ($;$) { my $self = shift; my $append_file = shift || $self->{rand_file}; $self->{lock_line} ||= "$HOSTNAME $self->{lock_pid} ".time()." ".int(rand()*10000)."\n"; - local *_FH; - open (_FH,">>$append_file") or do { $errstr = "Couldn't open \"$append_file\" [$!]"; return undef; }; - print _FH $self->{lock_line}; - close _FH; + open (my $fh,'>>', $append_file) or do { $errstr = "Couldn't open \"$append_file\" [$!]"; return undef; }; + print $fh $self->{lock_line}; + close $fh; return 1; } @@ -394,8 +394,8 @@ sub do_unlock_shared ($) { my $lock = new File::NFSLock ($lock_file,LOCK_EX,62,60); ### get the handle on the lock file - local *_FH; - if( ! open (_FH,"+<$lock_file") ){ + my $fh; + if( ! open ($fh,'+<', $lock_file) ){ if( ! -e $lock_file ){ return 1; }else{ @@ -405,21 +405,21 @@ sub do_unlock_shared ($) { ### read existing file my $content = ''; - while(defined(my $line=<_FH>)){ + 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; + seek $fh, 0, 0; + print $fh $content; + truncate $fh, length($content); + close $fh; ### only I exist }else{ - close _FH; + close $fh; unlink $lock_file; } @@ -456,36 +456,67 @@ sub newpid { 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; + # 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 - # 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}; + + # 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}); - # Remove the old lock_line from lock_file. - local $self->{lock_line} = $old_line; - $self->do_unlock_shared; + + 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 (_FH, ">$self->{lock_file}.fork"); - close(_FH); + 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 @@ -621,6 +652,8 @@ 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, @@ -632,7 +665,7 @@ additional functionality. $lock->unlock; This method may be used to explicitly release a lock -that is aquired. In most cases, it is not necessary +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. @@ -649,29 +682,45 @@ 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) { + if (!defined $pid) { # Fork Failed } elsif ($pid) { - $lock->newpid; # Parent + $lock->newpid; + # Parent ... } else { - $lock->newpid; # Child + $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. +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 @@ -680,13 +729,21 @@ 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 +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 -Notify paul@seamons.com or bbb@cpan.org if you spot anything. +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 @@ -694,7 +751,6 @@ 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 @@ -742,7 +798,7 @@ from which Mark Overmeer based Mail::Box::Locker. paul@seamons.com http://seamons.com/ - Copyright (C) 2002-2003, + Copyright (C) 2002-2018, Rob B Brown bbb@cpan.org diff --git a/t/100_load.t b/t/100_load.t index 1e335e8..7b2461a 100644 --- a/t/100_load.t +++ b/t/100_load.t @@ -2,20 +2,10 @@ # `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; -BEGIN { plan tests => 1; $loaded = 0} -END { ok $loaded;} +use Test::More tests => 1; +use File::Temp qw(tempfile); -# Just make sure everything compiles -use File::NFSLock; -use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC O_APPEND LOCK_EX LOCK_SH LOCK_NB); -#use POSIX qw(tmpnam); - -$loaded = 1; - -######################### End of black magic. - -# Insert your test code below (better if it prints "ok 13" -# (correspondingly "not ok 13") depending on the success of chunk 13 -# of the test code): +use_ok 'File::NFSLock'; diff --git a/t/110_compare.t b/t/110_compare.t index 17a6393..0661c19 100644 --- a/t/110_compare.t +++ b/t/110_compare.t @@ -1,14 +1,12 @@ -use Test; +use strict; +use warnings; + +use Test::More tests => 3; use File::NFSLock; use Fcntl; -plan tests => 4; - -# Everything loaded fine -ok (1); - # Make sure File::NFSLock has the correct # constants according to Fcntl -ok (&File::NFSLock::LOCK_SH(),&Fcntl::LOCK_SH()); -ok (&File::NFSLock::LOCK_EX(),&Fcntl::LOCK_EX()); -ok (&File::NFSLock::LOCK_NB(),&Fcntl::LOCK_NB()); +is (&File::NFSLock::LOCK_SH(),&Fcntl::LOCK_SH()); +is (&File::NFSLock::LOCK_EX(),&Fcntl::LOCK_EX()); +is (&File::NFSLock::LOCK_NB(),&Fcntl::LOCK_NB()); diff --git a/t/120_single.t b/t/120_single.t index 90eb9a8..3c1112e 100644 --- a/t/120_single.t +++ b/t/120_single.t @@ -1,19 +1,15 @@ # Blocking Exclusive test within a single process (no fork) -use Test; +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); -plan tests => 3; - -# Everything loaded fine -ok (1); - -my $datafile = "testfile.dat"; +my $datafile = (tempfile 'XXXXXXXXXX')[1]; # Create a blank file -sysopen ( FH, $datafile, O_CREAT | O_RDWR | O_TRUNC ); -close (FH); +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"; @@ -26,26 +22,26 @@ for (my $i = 0; $i < $n ; $i++) { file => $datafile, lock_type => LOCK_EX, }; - sysopen(FH, $datafile, O_RDWR); + sysopen(my $fh, $datafile, O_RDWR); # Read the current value - my $count = ; + my $count = <$fh>; # Increment it $count ++; # And put it back - seek (FH,0,0); - print FH "$count\n"; - close FH; + seek ($fh,0,0); + print $fh "$count\n"; + close $fh; } # Load up whatever the file says now -sysopen(FH, $datafile, O_RDONLY); -$_ = ; -close FH; +sysopen($fh, $datafile, O_RDONLY); +$_ = <$fh>; +close $fh; chomp; # It should be the same as the number of times it looped -ok $n, $_; +is $n, $_; # Wipe the temporary file unlink $datafile; diff --git a/t/130_taint.t b/t/130_taint.t new file mode 100644 index 0000000..8ddbb98 --- /dev/null +++ b/t/130_taint.t @@ -0,0 +1,49 @@ +#!/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; diff --git a/t/200_bl_ex.t b/t/200_bl_ex.t index 70378d9..3e80fa8 100644 --- a/t/200_bl_ex.t +++ b/t/200_bl_ex.t @@ -1,6 +1,16 @@ # Blocking Exclusive Lock Test -use 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); @@ -9,13 +19,12 @@ my $m = 20; my $n = 50; $| = 1; # Buffer must be autoflushed because of fork() below. -plan tests => ($m+2); -my $datafile = "testfile.dat"; +my $datafile = (tempfile 'XXXXXXXXXX')[1]; # Create a blank file -sysopen ( FH, $datafile, O_CREAT | O_RDWR | O_TRUNC ); -close (FH); +sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); +close ($fh); ok (-e $datafile && !-s _); for (my $i = 0; $i < $m ; $i++) { @@ -27,15 +36,15 @@ for (my $i = 0; $i < $m ; $i++) { file => $datafile, lock_type => LOCK_EX, }; - sysopen(FH, $datafile, O_RDWR); + sysopen(my $fh, $datafile, O_RDWR); # Read the current value - my $count = ; + my $count = <$fh>; # Increment it $count ++; # And put it back - seek (FH,0,0); - print FH "$count\n"; - close FH; + seek ($fh,0,0); + print $fh "$count\n"; + close $fh; } exit; } @@ -48,12 +57,12 @@ for (my $i = 0; $i < $m ; $i++) { } # Load up whatever the file says now -sysopen(FH, $datafile, O_RDONLY); -$_ = ; -close FH; +sysopen(my $fh2, $datafile, O_RDONLY); +$_ = <$fh2>; +close $fh2; chomp; # It should be $m processes time $n each -ok $n*$m, $_; +is $n*$m, $_; # Wipe the temporary file unlink $datafile; diff --git a/t/210_nb_ex.t b/t/210_nb_ex.t index 4e8c9bb..59f91e1 100644 --- a/t/210_nb_ex.t +++ b/t/210_nb_ex.t @@ -1,72 +1,76 @@ +use strict; +use warnings; +use File::Temp qw(tempfile); + # Non-Blocking Exclusive Lock Test -use 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. -plan tests => 8; -my $datafile = "testfile.dat"; +my $datafile = (tempfile 'XXXXXXXXXX')[1]; # Create a blank file -sysopen ( FH, $datafile, O_CREAT | O_RDWR | O_TRUNC ); -close (FH); +sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); +close ($fh); ok (-e $datafile && !-s _); - -ok (pipe(RD1,WR1)); # Connected pipe for child1 +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); + 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(FH, $datafile, O_RDWR); + sysopen(my $fh, $datafile, O_RDWR); # now put a magic word into the file - print FH "child1\n"; - close FH; + print $fh "child1\n"; + close $fh; } exit; } ok 1; # Fork successful -close (WR1); +close ($wr1); # Waiting for child1 to finish its lock status -my $child1_lock = ; -close (RD1); +my $child1_lock = <$rd1>; +close ($rd1); # Report status of the child1_lock. # It should have been successful ok ($child1_lock); -ok (pipe(RD2,WR2)); # Connected pipe for child2 +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); + 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(FH, $datafile, O_RDWR); + sysopen(my $fh, $datafile, O_RDWR); # now put a magic word into the file - print FH "child2\n"; - close FH; + print $fh "child2\n"; + close $fh; } exit; } ok 1; # Fork successful -close (WR2); +close ($wr2); # Waiting for child2 to finish its lock status -my $child2_lock = ; -close (RD2); +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. @@ -76,9 +80,9 @@ ok (!$child2_lock); wait; wait; # Load up whatever the file says now -sysopen(FH, $datafile, O_RDONLY); -$_ = ; -close FH; +sysopen(my $fh2, $datafile, O_RDONLY); +$_ = <$fh2>; +close $fh2; # It should be child1 if it was really nonblocking # since it got the lock first. diff --git a/t/220_ex_scope.t b/t/220_ex_scope.t index 695fec1..f4acc0b 100644 --- a/t/220_ex_scope.t +++ b/t/220_ex_scope.t @@ -9,101 +9,113 @@ # 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 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 => 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. -plan tests => 11; -my $datafile = "testfile.dat"; +my $datafile = (tempfile 'XXXXXXXXXX')[1]; # Create a blank file -sysopen ( FH, $datafile, O_CREAT | O_RDWR | O_TRUNC ); -close (FH); +sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); +close ($fh); ok (-e $datafile && !-s _); -ok (pipe(RD1,WR1)); # Connected pipe for child1 +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); + 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(FH, $datafile, O_RDWR); + sysopen(my $fh, $datafile, O_RDWR); # now put a magic word into the file - print FH "child1\n"; - close FH; + print $fh "child1\n"; + close $fh; } exit; } ok 1; # Fork successful -close (WR1); +close ($wr1); # Waiting for child1 to finish its lock status -my $child1_lock = ; -close (RD1); +my $child1_lock = <$rd1>; +close ($rd1); # Report status of the child1_lock. # It should have been successful ok ($child1_lock); -ok (pipe(RD2,WR2)); # Connected pipe for child2 +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); + 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(FH, $datafile, O_RDWR); + sysopen(my $fh, $datafile, O_RDWR); # now put a magic word into the file - print FH "child2\n"; - close FH; + print $fh "child2\n"; + close $fh; } exit; } ok 1; # Fork successful -close (WR2); +close ($wr2); # Waiting for child2 to finish its lock status -my $child2_lock = ; -close (RD2); +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); -ok (pipe(RD3,WR3)); # Connected pipe for child3 +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(RD3); + 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(FH, $datafile, O_RDWR); + sysopen(my $fh, $datafile, O_RDWR); # now put a magic word into the file - print FH "child3\n"; - close FH; + print $fh "child3\n"; + close $fh; } exit; } ok 1; # Fork successful -close (WR3); +close ($wr3); # Waiting for child2 to finish its lock status -my $child3_lock = ; -close (RD3); +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. @@ -113,9 +125,9 @@ ok (!$child3_lock); wait; wait; wait; # Load up whatever the file says now -sysopen(FH, $datafile, O_RDONLY); -$_ = ; -close FH; +sysopen(my $fh2, $datafile, O_RDONLY); +$_ = <$fh2>; +close $fh2; # It should be child1 if it was really nonblocking # since it got the lock first. diff --git a/t/230_double.t b/t/230_double.t index 362fe61..b324f69 100644 --- a/t/230_double.t +++ b/t/230_double.t @@ -1,24 +1,26 @@ # Exclusive Double Lock Test # -# This tests to make sure the same process can aquire +# This tests to make sure the same process can acquire # an exclusive lock multiple times for the same file. use strict; -use Test; +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; -plan tests => 5; -my $datafile = "testfile.dat"; +my $datafile = (tempfile 'XXXXXXXXXX')[1]; # Wipe lock file in case it exists unlink ("$datafile$File::NFSLock::LOCK_EXTENSION"); # Create a blank file -sysopen ( FH, $datafile, O_CREAT | O_RDWR | O_TRUNC ); -close (FH); +sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); +close ($fh); ok (-e $datafile && !-s _); @@ -30,9 +32,9 @@ my $lock1 = new File::NFSLock { ok ($lock1); -sysopen(FH, $datafile, O_RDWR | O_APPEND); -print FH "lock1\n"; -close FH; +sysopen(my $fh2, $datafile, O_RDWR | O_APPEND); +print $fh2 "lock1\n"; +close $fh2; my $lock2 = new File::NFSLock { file => $datafile, @@ -42,17 +44,17 @@ my $lock2 = new File::NFSLock { ok ($lock2); -sysopen(FH, $datafile, O_RDWR | O_APPEND); -print FH "lock2\n"; -close FH; +sysopen(my $fh3, $datafile, O_RDWR | O_APPEND); +print $fh3 "lock2\n"; +close $fh3; # Load up whatever the file says now -sysopen(FH, $datafile, O_RDONLY); -$_ = ; +sysopen(my $fh4, $datafile, O_RDONLY); +$_ = <$fh4>; ok /lock1/; -$_ = ; +$_ = <$fh4>; ok /lock2/; -close FH; +close $fh4; # Wipe the temporary file unlink $datafile; diff --git a/t/240_fork.t b/t/240_fork_ex.t similarity index 60% rename from t/240_fork.t rename to t/240_fork_ex.t index 12a9ba1..e5cd525 100644 --- a/t/240_fork.t +++ b/t/240_fork_ex.t @@ -1,27 +1,29 @@ -# Fork Test +# Exclusive Fork Test # # This tests the capabilities of fork after lock to -# allow a parent to delegate the lock to its child. +# ensure child retains exclusive lock even if parent releases it. use strict; -use Test; +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. -plan tests => 5; -my $datafile = "testfile.dat"; +my $datafile = (tempfile 'XXXXXXXXXX')[1]; # Wipe lock file in case it exists unlink ("$datafile$File::NFSLock::LOCK_EXTENSION"); # Create a blank file -sysopen ( FH, $datafile, O_CREAT | O_RDWR | O_TRUNC ); -close (FH); +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, @@ -51,32 +53,43 @@ if (1) { } else { # Fork worked ok 1; - # Avoid releasing lock - # because child should do it. + # Both parent and child must unlock + # before the lock is truly released. $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; +# 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. -my $lock2 = new File::NFSLock { - file => $datafile, - lock_type => LOCK_EX|LOCK_NB, -}; +{ + # Forced dummy scope + my $lock2 = new File::NFSLock { + file => $datafile, + lock_type => LOCK_EX|LOCK_NB, + }; -ok (!$lock2); + 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; diff --git a/t/241_fork_ex.t b/t/241_fork_ex.t new file mode 100644 index 0000000..e53ba78 --- /dev/null +++ b/t/241_fork_ex.t @@ -0,0 +1,114 @@ +# 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; diff --git a/t/242_fork_ex.t b/t/242_fork_ex.t new file mode 100644 index 0000000..9c79c03 --- /dev/null +++ b/t/242_fork_ex.t @@ -0,0 +1,88 @@ +# 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; diff --git a/t/243_fork_ex.t b/t/243_fork_ex.t new file mode 100644 index 0000000..b856e7a --- /dev/null +++ b/t/243_fork_ex.t @@ -0,0 +1,105 @@ +# 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; diff --git a/t/250_fork_sh.t b/t/250_fork_sh.t new file mode 100644 index 0000000..52428dc --- /dev/null +++ b/t/250_fork_sh.t @@ -0,0 +1,95 @@ +# 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; diff --git a/t/251_fork_sh.t b/t/251_fork_sh.t new file mode 100644 index 0000000..32569a6 --- /dev/null +++ b/t/251_fork_sh.t @@ -0,0 +1,114 @@ +# 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; diff --git a/t/252_fork_sh.t b/t/252_fork_sh.t new file mode 100644 index 0000000..3b78fb3 --- /dev/null +++ b/t/252_fork_sh.t @@ -0,0 +1,88 @@ +# 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; diff --git a/t/253_fork_sh.t b/t/253_fork_sh.t new file mode 100644 index 0000000..05a553e --- /dev/null +++ b/t/253_fork_sh.t @@ -0,0 +1,105 @@ +# 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; diff --git a/t/300_bl_sh.t b/t/300_bl_sh.t index 52c3797..4c6d6c5 100644 --- a/t/300_bl_sh.t +++ b/t/300_bl_sh.t @@ -1,6 +1,15 @@ # Blocking Shared Lock Test +use strict; +use warnings; +use File::Temp qw(tempfile); -use Test; +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); @@ -9,19 +18,18 @@ my $m = 20; my $shared_delay = 5; $| = 1; # Buffer must be autoflushed because of fork() below. -plan tests => (13 + 3*$m); -my $datafile = "testfile.dat"; +my $datafile = (tempfile 'XXXXXXXXXX')[1]; # Create a blank file -sysopen ( FH, $datafile, O_CREAT | O_RDWR | O_TRUNC ); -close (FH); +sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); +close ($fh); # test 1 ok (-e $datafile && !-s _); -# test 2 -ok (pipe(RD1,WR1)); # Connected pipe for child1 +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 @@ -29,32 +37,32 @@ if (!fork) { 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); + 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(FH, $datafile, O_RDWR | O_TRUNC); + sysopen(my $fh, $datafile, O_RDWR | O_TRUNC); # And then put a magic word into the file - print FH "exclusive\n"; - close FH; + print $fh "exclusive\n"; + close $fh; } exit; } # test 3 ok 1; # Fork successful -close (WR1); +close ($wr1); # Waiting for child1 to finish its lock status -my $child1_lock = ; -close (RD1); +my $child1_lock = <$rd1>; +close ($rd1); # Report status of the child1_lock. # It should have been successful # test 4 ok ($child1_lock); -# test 5 -ok (pipe(RD2,WR2)); # Connected pipe for child2 +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 { @@ -62,11 +70,11 @@ if (!fork) { lock_type => LOCK_SH, }; if ($lock) { - sysopen(FH, $datafile, O_RDWR | O_TRUNC); + 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; + 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 @@ -76,9 +84,9 @@ if (!fork) { # 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); + 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); @@ -86,10 +94,10 @@ if (!fork) { } # test 6 ok 1; # Fork successful -close (WR2); +close ($wr2); # Waiting for child2 to finish its lock status -my $child2_lock = ; -close (RD2); +my $child2_lock = <$rd2>; +close ($rd2); # Report status of the child2_lock. # This should have eventually been successful. # test 7 @@ -110,10 +118,11 @@ $SIG{ALRM} = sub { # Use pipe to read lock success status from children # test 8 -ok (pipe(RD3,WR3)); +my ($rd3, $wr3); +ok (pipe($rd3, $wr3)); # Wait a few seconds less than if all locks were -# aquired asyncronously to ensure that they overlap. +# acquired asyncronously to ensure that they overlap. alarm($m*$shared_delay-2); for (my $i = 0; $i < $m ; $i++) { @@ -125,15 +134,15 @@ for (my $i = 0; $i < $m ; $i++) { lock_type => LOCK_SH, }; # Send boolean success status down pipe - print WR3 !!$lock,"\n"; - close(WR3); + 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(FH, $datafile, O_RDWR | O_APPEND); + sysopen(my $fh, $datafile, O_RDWR | O_APPEND); # Put one line to signal the lock was successful. - print FH "1\n"; - close FH; + print $fh "1\n"; + close $fh; $lock->unlock(); } else { warn "Lock [$i] failed!"; @@ -143,22 +152,22 @@ for (my $i = 0; $i < $m ; $i++) { } # Parent process never writes to pipe -close(WR3); +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 = ; + my $got_shared_lock = <$rd3>; # test 9 .. 8+$m ok $got_shared_lock; } # There should not be anything left in the pipe. -my $extra = ; +my $extra = <$rd3>; # test 9 + $m ok !$extra; -close (RD3); +close ($rd3); # If we made it here, then it must have been faster # than the timeout. So reset the timer. @@ -176,21 +185,21 @@ for (my $i = 0; $i < $m + 2 ; $i++) { } # Load up whatever the file says now -sysopen(FH, $datafile, O_RDONLY); +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 - ok $_, 1; + is $_, 1; } -close FH; +close $fh2; # Wipe the temporary file unlink $datafile; diff --git a/t/400_kill.t b/t/400_kill.t index 3926f2d..1045fa7 100644 --- a/t/400_kill.t +++ b/t/400_kill.t @@ -1,26 +1,30 @@ # Lock Test with graceful termination (SIGTERM or SIGINT) -use Test; +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. -plan tests => 10; -my $datafile = "testfile.dat"; +my $datafile = (tempfile 'XXXXXXXXXX')[1]; # Wipe lock file in case it exists unlink ("$datafile$File::NFSLock::LOCK_EXTENSION"); # Create a blank file -sysopen ( FH, $datafile, O_CREAT | O_RDWR | O_TRUNC ); -close (FH); +sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); +close ($fh); # test 1 ok (-e $datafile && !-s _); # test 2 -ok (pipe(RD1,WR1)); # Connected pipe for child1 +my ($rd1, $wr1); +ok (pipe($rd1, $wr1)); # Connected pipe for child1 my $pid = fork; if (!$pid) { @@ -31,25 +35,25 @@ if (!$pid) { 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); + 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(FH, $datafile, O_RDWR | O_TRUNC); + sysopen(my $fh, $datafile, O_RDWR | O_TRUNC); # And then put a magic word into the file - print FH "exclusive\n"; - close FH; + print $fh "exclusive\n"; + close $fh; } exit; } # test 3 ok 1; # Fork successful -close (WR1); +close ($wr1); # Waiting for child1 to finish its lock status -my $child1_lock = ; -close (RD1); +my $child1_lock = <$rd1>; +close ($rd1); # Report status of the child1_lock. # It should have been successful # test 4 @@ -64,45 +68,46 @@ ok (kill "INT", $pid); ok (wait); # test 7 -ok (pipe(RD2,WR2)); # Connected pipe for child2 +my ($rd2, $wr2); +ok (pipe($rd2, $wr2)); # Connected pipe for child2 if (!fork) { - # The last lock died, so this should aquire fine. + # 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(FH, $datafile, O_RDWR | O_TRUNC); + 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 $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); + 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); +close ($wr2); # Waiting for child2 to finish its lock status -my $child2_lock = ; -close (RD2); +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(FH, $datafile, O_RDONLY); +sysopen(my $fh2, $datafile, O_RDONLY); -$_ = ; +$_ = <$fh2>; # test 10 ok /lock2/; -close FH; +close $fh2; # Wipe the temporary file unlink $datafile; diff --git a/t/410_die.t b/t/410_die.t index f964f5d..67d937c 100644 --- a/t/410_die.t +++ b/t/410_die.t @@ -1,26 +1,30 @@ # Lock Test with fatal error (die) -use Test; +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. -plan tests => 9; -my $datafile = "testfile.dat"; +my $datafile = (tempfile 'XXXXXXXXXX')[1]; # Wipe lock file in case it exists unlink ("$datafile$File::NFSLock::LOCK_EXTENSION"); # Create a blank file -sysopen ( FH, $datafile, O_CREAT | O_RDWR | O_TRUNC ); -close (FH); +sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); +close ($fh); # test 1 ok (-e $datafile && !-s _); # test 2 -ok (pipe(RD1,WR1)); # Connected pipe for child1 +my ($rd1, $wr1); +ok (pipe($rd1, $wr1)); # Connected pipe for child1 my $pid = fork; if (!$pid) { @@ -30,26 +34,26 @@ if (!$pid) { 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); + 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(FH, $datafile, O_RDWR | O_TRUNC); + sysopen(my $fh, $datafile, O_RDWR | O_TRUNC); # And then put a magic word into the file - print FH "exclusive\n"; - close FH; + print $fh "exclusive\n"; + close $fh; open(STDERR,">/dev/null"); - die "I will die while lock is still aquired"; + die "I will die while lock is still acquired"; } die "Lock failed!"; } # test 3 ok 1; # Fork successful -close (WR1); +close ($wr1); # Waiting for child1 to finish its lock status -my $child1_lock = ; -close (RD1); +my $child1_lock = <$rd1>; +close ($rd1); # Report status of the child1_lock. # It should have been successful # test 4 @@ -60,45 +64,46 @@ ok ($child1_lock); ok (wait); # test 6 -ok (pipe(RD2,WR2)); # Connected pipe for child2 +my ($rd2, $wr2); +ok (pipe($rd2, $wr2)); # Connected pipe for child2 if (!fork) { - # The last lock died, so this should aquire fine. + # 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(FH, $datafile, O_RDWR | O_TRUNC); + 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 $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); + 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); +close ($wr2); # Waiting for child2 to finish its lock status -my $child2_lock = ; -close (RD2); +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(FH, $datafile, O_RDONLY); +sysopen(my $fh2, $datafile, O_RDONLY); -$_ = ; +$_ = <$fh2>; # test 9 ok /lock2/; -close FH; +close $fh2; # Wipe the temporary file unlink $datafile; diff --git a/t/420_crash.t b/t/420_crash.t index 2238f70..3867923 100644 --- a/t/420_crash.t +++ b/t/420_crash.t @@ -1,26 +1,30 @@ # Lock Test with abnormal or abrupt termination (System crash or SIGKILL) -use Test; +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. -plan tests => 10; -my $datafile = "testfile.dat"; +my $datafile = (tempfile 'XXXXXXXXXX')[1]; # Wipe lock file in case it exists unlink ("$datafile$File::NFSLock::LOCK_EXTENSION"); # Create a blank file -sysopen ( FH, $datafile, O_CREAT | O_RDWR | O_TRUNC ); -close (FH); +sysopen ( my $fh, $datafile, O_CREAT | O_RDWR | O_TRUNC ); +close ($fh); # test 1 ok (-e $datafile && !-s _); # test 2 -ok (pipe(RD1,WR1)); # Connected pipe for child1 +my ($rd1, $wr1); +ok (pipe($rd1, $wr1)); # Connected pipe for child1 my $pid = fork; if (!$pid) { @@ -31,31 +35,31 @@ if (!$pid) { 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); + 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(FH, $datafile, O_RDWR | O_TRUNC); + sysopen(my $fh, $datafile, O_RDWR | O_TRUNC); # And then put a magic word into the file - print FH "exclusive\n"; - close FH; + print $fh "exclusive\n"; + close $fh; } exit; } # test 3 ok 1; # Fork successful -close (WR1); +close ($wr1); # Waiting for child1 to finish its lock status -my $child1_lock = ; -close (RD1); +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 +# Pretend like the box crashed rudely while the lock is acquired # test 5 ok (kill "KILL", $pid); @@ -64,45 +68,46 @@ ok (kill "KILL", $pid); ok (wait); # test 7 -ok (pipe(RD2,WR2)); # Connected pipe for child2 +my ($rd2, $wr2); +ok (pipe($rd2, $wr2)); # Connected pipe for child2 if (!fork) { - # The last lock died, so this should aquire fine. + # 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(FH, $datafile, O_RDWR | O_TRUNC); + 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 $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); + 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); +close ($wr2); # Waiting for child2 to finish its lock status -my $child2_lock = ; -close (RD2); +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(FH, $datafile, O_RDONLY); +sysopen(my $fh2, $datafile, O_RDONLY); -$_ = ; +$_ = <$fh2>; # test 10 ok /lock2/; -close FH; +close $fh2; # Wipe the temporary file unlink $datafile; diff --git a/t/430_taint.t b/t/430_taint.t new file mode 100644 index 0000000..3a00e72 --- /dev/null +++ b/t/430_taint.t @@ -0,0 +1,115 @@ +#!/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;