[libfile-nfslock-perl] 01/25: [svn-inject] Installing original source of libfile-nfslock-perl
dom at earth.li
dom at earth.li
Sat Oct 4 21:56:31 UTC 2014
This is an automated email from the git hooks/post-receive script.
dom pushed a commit to branch master
in repository libfile-nfslock-perl.
commit 3a6ede0c23a54188d3b68c37805b5ce88e3e48a1
Author: Dominic Hargreaves <dom at earth.li>
Date: Tue Oct 23 22:24:54 2007 +0000
[svn-inject] Installing original source of libfile-nfslock-perl
---
Changes | 80 ++++++
File-NFSLock.spec | 64 +++++
File-NFSLock.spec.PL | 115 ++++++++
MANIFEST | 20 ++
Makefile.PL | 53 ++++
README | 245 +++++++++++++++++
examples/lock_test | 38 +++
lib/File/NFSLock.pm | 756 +++++++++++++++++++++++++++++++++++++++++++++++++++
t/100_load.t | 21 ++
t/110_compare.t | 14 +
t/120_single.t | 51 ++++
t/200_bl_ex.t | 59 ++++
t/210_nb_ex.t | 88 ++++++
t/220_ex_scope.t | 125 +++++++++
t/230_double.t | 58 ++++
t/240_fork.t | 82 ++++++
t/300_bl_sh.t | 196 +++++++++++++
t/400_kill.t | 108 ++++++++
t/410_die.t | 104 +++++++
t/420_crash.t | 108 ++++++++
20 files changed, 2385 insertions(+)
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..9d18164
--- /dev/null
+++ b/Changes
@@ -0,0 +1,80 @@
+Revision history for Perl extension File::NFSLock.
+
+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 at 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.
diff --git a/File-NFSLock.spec b/File-NFSLock.spec
new file mode 100644
index 0000000..44e1c30
--- /dev/null
+++ b/File-NFSLock.spec
@@ -0,0 +1,64 @@
+# Automatically generated by File-NFSLock.spec.PL
+%define class File
+%define subclass NFSLock
+%define version 1.20
+%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 <bbb at cpan.org>
+Packager: Rob Brown <bbb at cpan.org>
+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 <bbb at cpan.org>
+- initial creation
diff --git a/File-NFSLock.spec.PL b/File-NFSLock.spec.PL
new file mode 100644
index 0000000..fdf9fdf
--- /dev/null
+++ b/File-NFSLock.spec.PL
@@ -0,0 +1,115 @@
+# Copyright (C) 2002 Rob Brown (bbb at 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;
+$_ = <DATA>;
+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 <bbb at cpan.org>
+Packager: Rob Brown <bbb at cpan.org>
+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 <bbb at cpan.org>
+- initial creation
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..cb44dc5
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,20 @@
+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/200_bl_ex.t
+t/210_nb_ex.t
+t/220_ex_scope.t
+t/230_double.t
+t/240_fork.t
+t/300_bl_sh.t
+t/400_kill.t
+t/410_die.t
+t/420_crash.t
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..abc3381
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,53 @@
+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;
diff --git a/README b/README
new file mode 100644
index 0000000..b684529
--- /dev/null
+++ b/README
@@ -0,0 +1,245 @@
+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
+ aquired. In most cases, it is not necessary to call unlock directly
+ since it will implicitly be called when the object leaves whatever
+ scope it is in.
+
+ uncache
+
+ $lock->uncache;
+ $lock->uncache("otherfile1");
+ uncache("otherfile2");
+
+ This method is used to freshen up the contents of a file across NFS,
+ ignoring what is contained in the NFS client cache. It is always
+ called from within the new constructor on the file that the lock is
+ being attempted. uncache may be used as either an object method or
+ as a stand alone subroutine.
+
+ newpid
+
+ my $pid = fork;
+ if (defined $pid) {
+ # Fork Failed
+ } elsif ($pid) {
+ $lock->newpid; # Parent
+ } else {
+ $lock->newpid; # Child
+ }
+
+ If fork() is called after a lock has been aquired, then when the
+ lock object leaves scope in either the parent or child, it will be
+ released. This behavior may be inappropriate for your application.
+ To delegate ownership of the lock from the parent to the child, both
+ the parent and child process must call the newpid() method after a
+ successful fork() call. This will prevent the parent from releasing
+ the lock when unlock is called or when the lock object leaves scope.
+ This is also useful to allow the parent to fail on subsequent lock
+ attempts if the child lock is still aquired.
+
+FAILURE
+ On failure, a global variable, $File::NFSLock::errstr, should be set
+ and should contain the cause for the failure to get a lock. Useful
+ primarily for debugging.
+
+LOCK_EXTENSION
+ By default File::NFSLock will use a lock file extenstion of
+ ".NFSLock". This is in a global variable
+ $File::NFSLock::LOCK_EXTENSION that may be changed to suit other
+ purposes (such as compatibility in mail systems).
+
+BUGS
+ Notify paul at seamons.com or bbb at cpan.org if you spot anything.
+
+ FIFO
+
+ Locks are not necessarily obtained on a first come first serve
+ basis. Not only does this not seem fair to new processes trying to
+ obtain a lock, but it may cause a process starvation condition on
+ heavily locked files.
+
+ DIRECTORIES
+
+ Locks cannot be obtained on directory nodes, nor can a directory
+ node be uncached with the uncache routine because hard links do not
+ work with directory nodes. Some other algorithm might be used to
+ uncache a directory, but I am unaware of the best way to do it. The
+ biggest use I can see would be to avoid NFS cache of directory
+ modified and last accessed timestamps.
+
+INSTALL
+ Download and extract tarball before running these commands in its
+ base directory:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+ For RPM installation, download tarball before running these commands
+ in your _topdir:
+
+ rpm -ta SOURCES/File-NFSLock-*.tar.gz
+ rpm -ih RPMS/noarch/perl-File-NFSLock-*.rpm
+
+AUTHORS
+ Paul T Seamons (paul at seamons.com) - Performed majority of the
+ programming with copious amounts of input from Rob Brown.
+
+ Rob B Brown (bbb at 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 at overmeer.net) - Author of
+ Mail::Box::Locker, from which some key concepts for File::NFSLock
+ were taken.
+
+ Also Kevin Johnson (kjj at pobox.com) - Author of
+ Mail::Folder::Maildir, from which Mark Overmeer based
+ Mail::Box::Locker.
+
+COPYRIGHT
+ Copyright (C) 2001
+ Paul T Seamons
+ paul at seamons.com
+ http://seamons.com/
+
+ Copyright (C) 2002-2003,
+ Rob B Brown
+ bbb at 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.
+
diff --git a/examples/lock_test b/examples/lock_test
new file mode 100755
index 0000000..719e559
--- /dev/null
+++ b/examples/lock_test
@@ -0,0 +1,38 @@
+#!/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 <filename> <increment>\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 = <FH>;
+ $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";
diff --git a/lib/File/NFSLock.pm b/lib/File/NFSLock.pm
new file mode 100644
index 0000000..cc5604d
--- /dev/null
+++ b/lib/File/NFSLock.pm
@@ -0,0 +1,756 @@
+# -*- perl -*-
+#
+# File::NFSLock - bdpO - NFS compatible (safe) locking utility
+#
+# $Id: NFSLock.pm,v 1.34 2003/05/13 18:06:41 hookbot Exp $
+#
+# Copyright (C) 2002, Paul T Seamons
+# paul at seamons.com
+# http://seamons.com/
+#
+# Rob B Brown
+# bbb at 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 Exporter ();
+use vars qw(@ISA @EXPORT_OK $VERSION $TYPES
+ $LOCK_EXTENSION $SHARE_BIT $HOSTNAME $errstr
+ $graceful_sig @CATCH_SIGS);
+use Carp qw(croak confess);
+
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(uncache);
+
+$VERSION = '1.20';
+
+#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}
+
+### Convert lock_type to a number
+$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,
+};
+$LOCK_EXTENSION = '.NFSLock'; # customizable extension
+$HOSTNAME = undef;
+$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;
+};
+
+ at 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
+
+ if ( -e $self->{lock_file} &&
+ open (_FH,"+<$self->{lock_file}") ){
+
+ my @mine = ();
+ my @them = ();
+ my @dead = ();
+
+ my $has_lock_exclusive = !((stat _)[2] & $SHARE_BIT);
+ my $try_lock_exclusive = !($self->{lock_type} & LOCK_SH);
+
+ while(defined(my $line=<_FH>)){
+ if ($line =~ /^$HOSTNAME (\d+) /) {
+ my $pid = $1;
+ if ($pid == $$) { # This is me.
+ push @mine, $line;
+ }elsif(kill 0, $pid) { # Still running on this host.
+ push @them, $line;
+ }else{ # Finished running on this host.
+ push @dead, $line;
+ }
+ } else { # Running on another host, so
+ push @them, $line; # assume it is still running.
+ }
+ }
+
+ ### If there was at least one stale lock discovered...
+ if (@dead) {
+ # Lock lock_file to avoid a race condition.
+ local $LOCK_EXTENSION = ".shared";
+ my $lock = new File::NFSLock {
+ file => $self->{lock_file},
+ lock_type => LOCK_EX,
+ blocking_timeout => 62,
+ stale_lock_timeout => 60,
+ };
+
+ ### Rescan in case lock contents were modified between time stale lock
+ ### was discovered and lockfile lock was acquired.
+ seek (_FH, 0, 0);
+ my $content = '';
+ while(defined(my $line=<_FH>)){
+ if ($line =~ /^$HOSTNAME (\d+) /) {
+ my $pid = $1;
+ next if (!kill 0, $pid); # Skip dead locks from this host
+ }
+ $content .= $line; # Save valid locks
+ }
+
+ ### Save any valid locks or wipe file.
+ if( length($content) ){
+ seek _FH, 0, 0;
+ print _FH $content;
+ truncate _FH, length($content);
+ close _FH;
+ }else{
+ close _FH;
+ unlink $self->{lock_file};
+ }
+
+ ### No "dead" or stale locks found.
+ } else {
+ close _FH;
+ }
+
+ ### If attempting to acquire the same type of lock
+ ### that it is already locked with, and I've already
+ ### locked it myself, then it is safe to lock again.
+ ### Just kick out successfully without really locking.
+ ### Assumes locks will be released in the reverse
+ ### order from how they were established.
+ if ($try_lock_exclusive eq $has_lock_exclusive && @mine){
+ return $self;
+ }
+ }
+
+ ### If non-blocking, then kick out now.
+ ### ($errstr might already be set to the reason.)
+ if ($self->{lock_type} & LOCK_NB) {
+ $errstr ||= "NONBLOCKING lock failed!";
+ return undef;
+ }
+
+ ### wait a moment
+ sleep(1);
+
+ ### but don't wait past the time out
+ if( $quit_time && (time > $quit_time) ){
+ $errstr = "Timed out waiting for blocking lock";
+ return undef;
+ }
+
+ # BLOCKING Lock, So Keep Trying
+ }
+
+ ### clear up the NFS cache
+ $self->uncache;
+
+ ### Yes, the lock has been aquired.
+ delete $self->{unlocked};
+
+ return $self;
+}
+
+sub DESTROY {
+ shift()->unlock();
+}
+
+sub unlock ($) {
+ my $self = shift;
+ if (!$self->{unlocked}) {
+ unlink( $self->{rand_file} ) if -e $self->{rand_file};
+ if( $self->{lock_type} & LOCK_SH ){
+ return $self->do_unlock_shared;
+ }else{
+ return $self->do_unlock;
+ }
+ $self->{unlocked} = 1;
+ foreach my $signal (@CATCH_SIGS) {
+ if ($SIG{$signal} &&
+ ($SIG{$signal} eq $graceful_sig)) {
+ # Revert handler back to how it used to be.
+ # Unfortunately, this will restore the
+ # handler back even if there are other
+ # locks still in tact, but for most cases,
+ # it will still be an improvement.
+ delete $SIG{$signal};
+ }
+ }
+ }
+ return 1;
+}
+
+###----------------------------------------------------------------###
+
+# concepts for these routines were taken from Mail::Box which
+# took the concepts from Mail::Folder
+
+
+sub rand_file ($) {
+ my $file = shift;
+ "$file.tmp.". time()%10000 .'.'. $$ .'.'. int(rand()*10000);
+}
+
+sub create_magic ($;$) {
+ $errstr = undef;
+ my $self = shift;
+ my $append_file = shift || $self->{rand_file};
+ $self->{lock_line} ||= "$HOSTNAME $self->{lock_pid} ".time()." ".int(rand()*10000)."\n";
+ local *_FH;
+ open (_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
+ local *_FH;
+ if( ! open (_FH,"+<$lock_file") ){
+ if( ! -e $lock_file ){
+ return 1;
+ }else{
+ die "Could not open for writing shared lock file $lock_file ($!)";
+ }
+ }
+
+ ### read existing file
+ my $content = '';
+ while(defined(my $line=<_FH>)){
+ next if $line eq $lock_line;
+ $content .= $line;
+ }
+
+ ### other shared locks exist
+ if( length($content) ){
+ seek _FH, 0, 0;
+ print _FH $content;
+ truncate _FH, length($content);
+ close _FH;
+
+ ### only I exist
+ }else{
+ close _FH;
+ unlink $lock_file;
+ }
+
+}
+
+sub uncache ($;$) {
+ # allow as method call
+ my $file = pop;
+ ref $file && ($file = $file->{file});
+ my $rand_file = rand_file( $file );
+
+ ### hard link to the actual file which will bring it up to date
+ return ( link( $file, $rand_file) && unlink($rand_file) );
+}
+
+sub newpid {
+ my $self = shift;
+ # Detect if this is the parent or the child
+ if ($self->{lock_pid} == $$) {
+ # This is the parent
+
+ # Must wait for child to call newpid before processing.
+ # A little patience for the child to call newpid
+ my $patience = time + 10;
+ while (time < $patience) {
+ if (rename("$self->{lock_file}.fork",$self->{rand_file})) {
+ # Child finished its newpid call.
+ # Wipe the signal file.
+ unlink $self->{rand_file};
+ last;
+ }
+ # Brief pause before checking again
+ # to avoid intensive IO across NFS.
+ select(undef,undef,undef,0.1);
+ }
+
+ # Fake the parent into thinking it is already
+ # unlocked because the child will take care of it.
+ $self->{unlocked} = 1;
+ } else {
+ # This is the new child
+
+ # The lock_line found in the lock_file contents
+ # must be modified to reflect the new pid.
+
+ # Fix lock_pid to the new pid.
+ $self->{lock_pid} = $$;
+ # Backup the old lock_line.
+ my $old_line = $self->{lock_line};
+ # Clear lock_line to create a fresh one.
+ delete $self->{lock_line};
+ # Append a new lock_line to the lock_file.
+ $self->create_magic($self->{lock_file});
+ # Remove the old lock_line from lock_file.
+ local $self->{lock_line} = $old_line;
+ $self->do_unlock_shared;
+ # Create signal file to notify parent that
+ # the lock_line entry has been delegated.
+ open (_FH, ">$self->{lock_file}.fork");
+ close(_FH);
+ }
+}
+
+1;
+
+
+=head1 NAME
+
+File::NFSLock - perl module to do NFS (or not) locking
+
+=head1 SYNOPSIS
+
+ use File::NFSLock qw(uncache);
+ use Fcntl qw(LOCK_EX LOCK_NB);
+
+ my $file = "somefile";
+
+ ### set up a lock - lasts until object looses scope
+ if (my $lock = new File::NFSLock {
+ file => $file,
+ lock_type => LOCK_EX|LOCK_NB,
+ blocking_timeout => 10, # 10 sec
+ stale_lock_timeout => 30 * 60, # 30 min
+ }) {
+
+ ### OR
+ ### my $lock = File::NFSLock->new($file,LOCK_EX|LOCK_NB,10,30*60);
+
+ ### do write protected stuff on $file
+ ### at this point $file is uncached from NFS (most recent)
+ open(FILE, "+<$file") || die $!;
+
+ ### or open it any way you like
+ ### my $fh = IO::File->open( $file, 'w' ) || die $!
+
+ ### update (uncache across NFS) other files
+ uncache("someotherfile1");
+ uncache("someotherfile2");
+ # open(FILE2,"someotherfile1");
+
+ ### unlock it
+ $lock->unlock();
+ ### OR
+ ### undef $lock;
+ ### OR let $lock go out of scope
+ }else{
+ die "I couldn't lock the file [$File::NFSLock::errstr]";
+ }
+
+
+=head1 DESCRIPTION
+
+Program based of concept of hard linking of files being atomic across
+NFS. This concept was mentioned in Mail::Box::Locker (which was
+originally presented in Mail::Folder::Maildir). Some routine flow is
+taken from there -- particularly the idea of creating a random local
+file, hard linking a common file to the local file, and then checking
+the nlink status. Some ideologies were not complete (uncache
+mechanism, shared locking) and some coding was even incorrect (wrong
+stat index). File::NFSLock was written to be light, generic,
+and fast.
+
+
+=head1 USAGE
+
+Locking occurs by creating a File::NFSLock object. If the object
+is created successfully, a lock is currently in place and remains in
+place until the lock object goes out of scope (or calls the unlock
+method).
+
+A lock object is created by calling the new method and passing two
+to four parameters in the following manner:
+
+ my $lock = File::NFSLock->new($file,
+ $lock_type,
+ $blocking_timeout,
+ $stale_lock_timeout,
+ );
+
+Additionally, parameters may be passed as a hashref:
+
+ my $lock = File::NFSLock->new({
+ file => $file,
+ lock_type => $lock_type,
+ blocking_timeout => $blocking_timeout,
+ stale_lock_timeout => $stale_lock_timeout,
+ });
+
+=head1 PARAMETERS
+
+=over 4
+
+=item Parameter 1: file
+
+Filename of the file upon which it is anticipated that a write will
+happen to. Locking will provide the most recent version (uncached)
+of this file upon a successful file lock. It is not necessary
+for this file to exist.
+
+=item Parameter 2: lock_type
+
+Lock type must be one of the following:
+
+ BLOCKING
+ BL
+ EXCLUSIVE (BLOCKING)
+ EX
+ NONBLOCKING
+ NB
+ SHARED
+ SH
+
+Or else one or more of the following joined with '|':
+
+ Fcntl::LOCK_EX() (BLOCKING)
+ Fcntl::LOCK_NB() (NONBLOCKING)
+ Fcntl::LOCK_SH() (SHARED)
+
+Lock type determines whether the lock will be blocking, non blocking,
+or shared. Blocking locks will wait until other locks are removed
+before the process continues. Non blocking locks will return undef if
+another process currently has the lock. Shared will allow other
+process to do a shared lock at the same time as long as there is not
+already an exclusive lock obtained.
+
+=item Parameter 3: blocking_timeout (optional)
+
+Timeout is used in conjunction with a blocking timeout. If specified,
+File::NFSLock will block up to the number of seconds specified in
+timeout before returning undef (could not get a lock).
+
+
+=item Parameter 4: stale_lock_timeout (optional)
+
+Timeout is used to see if an existing lock file is older than the stale
+lock timeout. If do_lock fails to get a lock, the modified time is checked
+and do_lock is attempted again. If the stale_lock_timeout is set to low, a
+recursion load could exist so do_lock will only recurse 10 times (this is only
+a problem if the stale_lock_timeout is set too low -- on the order of one or two
+seconds).
+
+=head1 METHODS
+
+After the $lock object is instantiated with new,
+as outlined above, some methods may be used for
+additional functionality.
+
+=head2 unlock
+
+ $lock->unlock;
+
+This method may be used to explicitly release a lock
+that is aquired. In most cases, it is not necessary
+to call unlock directly since it will implicitly be
+called when the object leaves whatever scope it is in.
+
+=head2 uncache
+
+ $lock->uncache;
+ $lock->uncache("otherfile1");
+ uncache("otherfile2");
+
+This method is used to freshen up the contents of a
+file across NFS, ignoring what is contained in the
+NFS client cache. It is always called from within
+the new constructor on the file that the lock is
+being attempted. uncache may be used as either an
+object method or as a stand alone subroutine.
+
+=head2 newpid
+
+ my $pid = fork;
+ if (defined $pid) {
+ # Fork Failed
+ } elsif ($pid) {
+ $lock->newpid; # Parent
+ } else {
+ $lock->newpid; # Child
+ }
+
+If fork() is called after a lock has been aquired,
+then when the lock object leaves scope in either
+the parent or child, it will be released. This
+behavior may be inappropriate for your application.
+To delegate ownership of the lock from the parent
+to the child, both the parent and child process
+must call the newpid() method after a successful
+fork() call. This will prevent the parent from
+releasing the lock when unlock is called or when
+the lock object leaves scope. This is also
+useful to allow the parent to fail on subsequent
+lock attempts if the child lock is still aquired.
+
+=head1 FAILURE
+
+On failure, a global variable, $File::NFSLock::errstr, should be set and should
+contain the cause for the failure to get a lock. Useful primarily for debugging.
+
+=head1 LOCK_EXTENSION
+
+By default File::NFSLock will use a lock file extenstion of ".NFSLock". This is
+in a global variable $File::NFSLock::LOCK_EXTENSION that may be changed to
+suit other purposes (such as compatibility in mail systems).
+
+=head1 BUGS
+
+Notify paul at seamons.com or bbb at cpan.org if you spot anything.
+
+=head2 FIFO
+
+Locks are not necessarily obtained on a first come first serve basis.
+Not only does this not seem fair to new processes trying to obtain a lock,
+but it may cause a process starvation condition on heavily locked files.
+
+
+=head2 DIRECTORIES
+
+Locks cannot be obtained on directory nodes, nor can a directory node be
+uncached with the uncache routine because hard links do not work with
+directory nodes. Some other algorithm might be used to uncache a
+directory, but I am unaware of the best way to do it. The biggest use I
+can see would be to avoid NFS cache of directory modified and last accessed
+timestamps.
+
+=head1 INSTALL
+
+Download and extract tarball before running
+these commands in its base directory:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+For RPM installation, download tarball before
+running these commands in your _topdir:
+
+ rpm -ta SOURCES/File-NFSLock-*.tar.gz
+ rpm -ih RPMS/noarch/perl-File-NFSLock-*.rpm
+
+=head1 AUTHORS
+
+Paul T Seamons (paul at seamons.com) - Performed majority of the
+programming with copious amounts of input from Rob Brown.
+
+Rob B Brown (bbb at 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 at overmeer.net) - Author of Mail::Box::Locker,
+from which some key concepts for File::NFSLock were taken.
+
+Also Kevin Johnson (kjj at pobox.com) - Author of Mail::Folder::Maildir,
+from which Mark Overmeer based Mail::Box::Locker.
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2001
+ Paul T Seamons
+ paul at seamons.com
+ http://seamons.com/
+
+ Copyright (C) 2002-2003,
+ Rob B Brown
+ bbb at 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
diff --git a/t/100_load.t b/t/100_load.t
new file mode 100644
index 0000000..1e335e8
--- /dev/null
+++ b/t/100_load.t
@@ -0,0 +1,21 @@
+# 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 Test;
+BEGIN { plan tests => 1; $loaded = 0}
+END { ok $loaded;}
+
+# 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):
diff --git a/t/110_compare.t b/t/110_compare.t
new file mode 100644
index 0000000..17a6393
--- /dev/null
+++ b/t/110_compare.t
@@ -0,0 +1,14 @@
+use Test;
+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());
diff --git a/t/120_single.t b/t/120_single.t
new file mode 100644
index 0000000..90eb9a8
--- /dev/null
+++ b/t/120_single.t
@@ -0,0 +1,51 @@
+# Blocking Exclusive test within a single process (no fork)
+
+use Test;
+use File::NFSLock;
+use Fcntl qw(O_CREAT O_RDWR O_RDONLY O_TRUNC LOCK_EX);
+
+plan tests => 3;
+
+# Everything loaded fine
+ok (1);
+
+my $datafile = "testfile.dat";
+
+# Create a blank file
+sysopen ( 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(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
+ok $n, $_;
+
+# Wipe the temporary file
+unlink $datafile;
diff --git a/t/200_bl_ex.t b/t/200_bl_ex.t
new file mode 100644
index 0000000..70378d9
--- /dev/null
+++ b/t/200_bl_ex.t
@@ -0,0 +1,59 @@
+# Blocking Exclusive Lock Test
+
+use Test;
+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.
+plan tests => ($m+2);
+
+my $datafile = "testfile.dat";
+
+# Create a blank file
+sysopen ( 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(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(FH, $datafile, O_RDONLY);
+$_ = <FH>;
+close FH;
+chomp;
+# It should be $m processes time $n each
+ok $n*$m, $_;
+
+# Wipe the temporary file
+unlink $datafile;
diff --git a/t/210_nb_ex.t b/t/210_nb_ex.t
new file mode 100644
index 0000000..4e8c9bb
--- /dev/null
+++ b/t/210_nb_ex.t
@@ -0,0 +1,88 @@
+# Non-Blocking Exclusive Lock Test
+
+use Test;
+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";
+
+# Create a blank file
+sysopen ( FH, $datafile, O_CREAT | O_RDWR | O_TRUNC );
+close (FH);
+ok (-e $datafile && !-s _);
+
+
+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(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);
+
+
+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(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(FH, $datafile, O_RDONLY);
+$_ = <FH>;
+close FH;
+
+# It should be child1 if it was really nonblocking
+# since it got the lock first.
+ok /child1/;
+
+# Wipe the temporary file
+unlink $datafile;
diff --git a/t/220_ex_scope.t b/t/220_ex_scope.t
new file mode 100644
index 0000000..695fec1
--- /dev/null
+++ b/t/220_ex_scope.t
@@ -0,0 +1,125 @@
+# 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 at 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 Test;
+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";
+
+# Create a blank file
+sysopen ( FH, $datafile, O_CREAT | O_RDWR | O_TRUNC );
+close (FH);
+ok (-e $datafile && !-s _);
+
+
+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(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);
+
+
+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(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);
+
+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);
+ if ($lock) {
+ sysopen(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(FH, $datafile, O_RDONLY);
+$_ = <FH>;
+close FH;
+
+# It should be child1 if it was really nonblocking
+# since it got the lock first.
+ok /child1/;
+
+# Wipe the temporary file
+unlink $datafile;
diff --git a/t/230_double.t b/t/230_double.t
new file mode 100644
index 0000000..362fe61
--- /dev/null
+++ b/t/230_double.t
@@ -0,0 +1,58 @@
+# Exclusive Double Lock Test
+#
+# This tests to make sure the same process can aquire
+# an exclusive lock multiple times for the same file.
+
+use strict;
+use Test;
+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";
+
+# 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);
+ok (-e $datafile && !-s _);
+
+
+my $lock1 = new File::NFSLock {
+ file => $datafile,
+ lock_type => LOCK_EX,
+ blocking_timeout => 10,
+};
+
+ok ($lock1);
+
+sysopen(FH, $datafile, O_RDWR | O_APPEND);
+print FH "lock1\n";
+close FH;
+
+my $lock2 = new File::NFSLock {
+ file => $datafile,
+ lock_type => LOCK_EX,
+ blocking_timeout => 10,
+};
+
+ok ($lock2);
+
+sysopen(FH, $datafile, O_RDWR | O_APPEND);
+print FH "lock2\n";
+close FH;
+
+# Load up whatever the file says now
+sysopen(FH, $datafile, O_RDONLY);
+$_ = <FH>;
+ok /lock1/;
+$_ = <FH>;
+ok /lock2/;
+close FH;
+
+# Wipe the temporary file
+unlink $datafile;
diff --git a/t/240_fork.t b/t/240_fork.t
new file mode 100644
index 0000000..12a9ba1
--- /dev/null
+++ b/t/240_fork.t
@@ -0,0 +1,82 @@
+# Fork Test
+#
+# This tests the capabilities of fork after lock to
+# allow a parent to delegate the lock to its child.
+
+use strict;
+use Test;
+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";
+
+# 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);
+ok (-e $datafile && !-s _);
+
+if (1) {
+ # Forced dummy scope
+ my $lock1 = new File::NFSLock {
+ file => $datafile,
+ lock_type => LOCK_EX,
+ };
+
+ ok ($lock1);
+
+ my $pid = fork;
+ if (!defined $pid) {
+ die "fork failed!";
+ } elsif (!$pid) {
+ # Child process
+
+ # Test possible race condition
+ # by making parent reach newpid()
+ # and attempt relock before child
+ # even calls newpid() the first time.
+ sleep 2;
+ $lock1->newpid;
+
+ # Act busy for a while
+ sleep 5;
+
+ # Now release lock
+ exit;
+ } else {
+ # Fork worked
+ ok 1;
+ # Avoid releasing lock
+ # because child should do it.
+ $lock1->newpid;
+ }
+}
+# Lock is out of scope, but
+# should still be acquired.
+
+#sysopen(FH, $datafile, O_RDWR | O_APPEND);
+#print FH "lock1\n";
+#close FH;
+
+# Try to get a non-blocking lock.
+# Yes, it is the same process,
+# but it should have been delegated
+# to the child process.
+# This lock should fail.
+my $lock2 = new File::NFSLock {
+ file => $datafile,
+ lock_type => LOCK_EX|LOCK_NB,
+};
+
+ok (!$lock2);
+
+# Wait for child to finish
+ok(wait);
+
+# Wipe the temporary file
+unlink $datafile;
diff --git a/t/300_bl_sh.t b/t/300_bl_sh.t
new file mode 100644
index 0000000..52c3797
--- /dev/null
+++ b/t/300_bl_sh.t
@@ -0,0 +1,196 @@
+# Blocking Shared Lock Test
+
+use Test;
+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.
+plan tests => (13 + 3*$m);
+
+my $datafile = "testfile.dat";
+
+# Create a blank file
+sysopen ( 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
+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(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);
+
+
+# test 5
+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(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
+ok (pipe(RD3,WR3));
+
+# Wait a few seconds less than if all locks were
+# aquired asyncronously to ensure that they overlap.
+alarm($m*$shared_delay-2);
+
+for (my $i = 0; $i < $m ; $i++) {
+ if (!fork) {
+ # All of these locks should immediately be successful since
+ # there already exist a shared lock.
+ my $lock = new File::NFSLock {
+ file => $datafile,
+ lock_type => LOCK_SH,
+ };
+ # Send boolean success status down pipe
+ print WR3 !!$lock,"\n";
+ close(WR3);
+ if ($lock) {
+ sleep $shared_delay; # Hold the shared lock for a moment
+ # Appending should always be safe across NFS
+ sysopen(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(FH, $datafile, O_RDONLY);
+
+# The first line should say "shared" if child2 really
+# waited for child1's exclusive lock to finish.
+$_ = <FH>;
+# test 13 + 2*$m
+ok /shared/;
+
+for (my $i = 0; $i < $m ; $i++) {
+ $_ = <FH>;
+ chomp;
+ # test 14+2*$m .. 13+3*$m
+ ok $_, 1;
+}
+close FH;
+
+# Wipe the temporary file
+unlink $datafile;
diff --git a/t/400_kill.t b/t/400_kill.t
new file mode 100644
index 0000000..3926f2d
--- /dev/null
+++ b/t/400_kill.t
@@ -0,0 +1,108 @@
+# Lock Test with graceful termination (SIGTERM or SIGINT)
+
+use Test;
+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";
+
+# 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);
+# test 1
+ok (-e $datafile && !-s _);
+
+
+# test 2
+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(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
+ok (pipe(RD2,WR2)); # Connected pipe for child2
+if (!fork) {
+ # The last lock died, so this should aquire fine.
+ my $lock = new File::NFSLock {
+ file => $datafile,
+ lock_type => LOCK_EX,
+ blocking_timeout => 10,
+ };
+ if ($lock) {
+ sysopen(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(FH, $datafile, O_RDONLY);
+
+$_ = <FH>;
+# test 10
+ok /lock2/;
+close FH;
+
+# Wipe the temporary file
+unlink $datafile;
diff --git a/t/410_die.t b/t/410_die.t
new file mode 100644
index 0000000..f964f5d
--- /dev/null
+++ b/t/410_die.t
@@ -0,0 +1,104 @@
+# Lock Test with fatal error (die)
+
+use Test;
+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";
+
+# 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);
+# test 1
+ok (-e $datafile && !-s _);
+
+
+# test 2
+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(RD1);
+ if ($lock) {
+ sysopen(FH, $datafile, O_RDWR | O_TRUNC);
+ # And then put a magic word into the file
+ print FH "exclusive\n";
+ close FH;
+ open(STDERR,">/dev/null");
+ die "I will die while lock is still aquired";
+ }
+ die "Lock failed!";
+}
+
+# test 3
+ok 1; # Fork successful
+close (WR1);
+# Waiting for child1 to finish its lock status
+my $child1_lock = <RD1>;
+close (RD1);
+# Report status of the child1_lock.
+# It should have been successful
+# test 4
+ok ($child1_lock);
+
+# Clear the zombie
+# test 5
+ok (wait);
+
+# test 6
+ok (pipe(RD2,WR2)); # Connected pipe for child2
+if (!fork) {
+ # The last lock died, so this should aquire fine.
+ my $lock = new File::NFSLock {
+ file => $datafile,
+ lock_type => LOCK_EX,
+ blocking_timeout => 10,
+ };
+ if ($lock) {
+ sysopen(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(FH, $datafile, O_RDONLY);
+
+$_ = <FH>;
+# test 9
+ok /lock2/;
+close FH;
+
+# Wipe the temporary file
+unlink $datafile;
diff --git a/t/420_crash.t b/t/420_crash.t
new file mode 100644
index 0000000..2238f70
--- /dev/null
+++ b/t/420_crash.t
@@ -0,0 +1,108 @@
+# Lock Test with abnormal or abrupt termination (System crash or SIGKILL)
+
+use Test;
+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";
+
+# 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);
+# test 1
+ok (-e $datafile && !-s _);
+
+
+# test 2
+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(FH, $datafile, O_RDWR | O_TRUNC);
+ # And then put a magic word into the file
+ print FH "exclusive\n";
+ close FH;
+ }
+ exit;
+}
+
+# test 3
+ok 1; # Fork successful
+close (WR1);
+# Waiting for child1 to finish its lock status
+my $child1_lock = <RD1>;
+close (RD1);
+# Report status of the child1_lock.
+# It should have been successful
+# test 4
+ok ($child1_lock);
+
+# Pretend like the box crashed rudely while the lock is aquired
+# test 5
+ok (kill "KILL", $pid);
+
+# Clear the zombie
+# test 6
+ok (wait);
+
+# test 7
+ok (pipe(RD2,WR2)); # Connected pipe for child2
+if (!fork) {
+ # The last lock died, so this should aquire fine.
+ my $lock = new File::NFSLock {
+ file => $datafile,
+ lock_type => LOCK_EX,
+ blocking_timeout => 10,
+ };
+ if ($lock) {
+ sysopen(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(FH, $datafile, O_RDONLY);
+
+$_ = <FH>;
+# test 10
+ok /lock2/;
+close FH;
+
+# Wipe the temporary file
+unlink $datafile;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libfile-nfslock-perl.git
More information about the Pkg-perl-cvs-commits
mailing list