r64955 - in /branches/upstream/libfile-flock-perl: ./ current/ current/CHANGELOG current/MANIFEST current/META.yml current/Makefile.PL current/README current/lib/ current/lib/File/ current/lib/File/Flock.pm current/t/ current/t/flock.t
zugschlus at users.alioth.debian.org
zugschlus at users.alioth.debian.org
Wed Nov 17 10:51:43 UTC 2010
Author: zugschlus
Date: Wed Nov 17 10:51:29 2010
New Revision: 64955
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=64955
Log:
[svn-inject] Installing original source of libfile-flock-perl (2008.01)
Added:
branches/upstream/libfile-flock-perl/
branches/upstream/libfile-flock-perl/current/
branches/upstream/libfile-flock-perl/current/CHANGELOG
branches/upstream/libfile-flock-perl/current/MANIFEST
branches/upstream/libfile-flock-perl/current/META.yml
branches/upstream/libfile-flock-perl/current/Makefile.PL
branches/upstream/libfile-flock-perl/current/README
branches/upstream/libfile-flock-perl/current/lib/
branches/upstream/libfile-flock-perl/current/lib/File/
branches/upstream/libfile-flock-perl/current/lib/File/Flock.pm
branches/upstream/libfile-flock-perl/current/t/
branches/upstream/libfile-flock-perl/current/t/flock.t (with props)
Added: branches/upstream/libfile-flock-perl/current/CHANGELOG
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-flock-perl/current/CHANGELOG?rev=64955&op=file
==============================================================================
--- branches/upstream/libfile-flock-perl/current/CHANGELOG (added)
+++ branches/upstream/libfile-flock-perl/current/CHANGELOG Wed Nov 17 10:51:29 2010
@@ -1,0 +1,67 @@
++ 2008/03/27 version 2008.01
+
+Joshua Kronengold, mneme at io dot com, sent in a patch
+to use IO::File instead of the $gensym hack. Applied.
+
+Carl Fürstenber, azatoth at gmail dot com and others
+requested that license terms be spelled out. Done.
+
++ 2004/11/19
+
+Bugfix in &unlock for if the lock file has been removed.
+
+Bugfix by Vadim O. Ustiansky <ustiansk at sai.msu.ru>.
+
++ 2001/06/05
+
+Added $av0debug variable to note locking attempts in $0
+
++ 2001/05/18
+
+Added lock_rename to the EXPORT list.
+
++ 2000/09/25
+
+Added tests to make sure 'nonblocking' works
+
++ 1999/12/17
+
+Added the lock_rename() function.
+
++ 1999/06/22
+
+SunOS systems seem to fail with EWOULDBLOCK on locked files.
+
++ 1999/06/21
+
+It appears that on some systems (HP-UX) a blocking call to flock()
+can fail with EACCES instead of EAGAIN.
+
++ 1999/06/15
+
+Perl changes. File::Flock must change to keep up. A call to
+lock() had to be changed to &lock(). Why?
+
++ 1998/12/01
+
+More fixes for Solaris.
+
+Modified the unlock() function so that it can be called as a reference.
+
++ 1998/11/30
+
+Fixed the object-style interface.
+
+Attempt to fix a double-unlock bug that makes the Linux port unhappy
+
++ 1998/11/26
+
+Chaged O_RDONLY to O_RDWR for all file opens because Solaris won't let
+you get an exclusive lock on a read-only file. Crazy! Change suggested
+by Lupe Christoph <lupe at alanya.m.isar.de>. Thanks!
+
+Rewrote the handling of the removal of files created just so that
+they could be locked. Also tried to make sure that now file descriptors
+could get leaked.
+
+
Added: branches/upstream/libfile-flock-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-flock-perl/current/MANIFEST?rev=64955&op=file
==============================================================================
--- branches/upstream/libfile-flock-perl/current/MANIFEST (added)
+++ branches/upstream/libfile-flock-perl/current/MANIFEST Wed Nov 17 10:51:29 2010
@@ -1,0 +1,7 @@
+MANIFEST
+CHANGELOG
+Makefile.PL
+README
+lib/File/Flock.pm
+t/flock.t
+META.yml Module meta-data (added by MakeMaker)
Added: branches/upstream/libfile-flock-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-flock-perl/current/META.yml?rev=64955&op=file
==============================================================================
--- branches/upstream/libfile-flock-perl/current/META.yml (added)
+++ branches/upstream/libfile-flock-perl/current/META.yml Wed Nov 17 10:51:29 2010
@@ -1,0 +1,10 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: File-Flock
+version: 2008.01
+version_from: lib/File/Flock.pm
+installdirs: site
+requires:
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.30_01
Added: branches/upstream/libfile-flock-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-flock-perl/current/Makefile.PL?rev=64955&op=file
==============================================================================
--- branches/upstream/libfile-flock-perl/current/Makefile.PL (added)
+++ branches/upstream/libfile-flock-perl/current/Makefile.PL Wed Nov 17 10:51:29 2010
@@ -1,0 +1,12 @@
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ 'VERSION_FROM' => 'lib/File/Flock.pm',
+ 'NAME' => 'File::Flock',
+ 'dist' => { COMPRESS=>"gzip", SUFFIX=>"gz" },
+ ($] >= 5.005 ?
+ ('ABSTRACT' => 'Wrapper for flock() to make file locking trivial',
+ 'AUTHOR' => 'David Muir Sharnoff <muir at idiom.com>') : ()),
+ );
+
Added: branches/upstream/libfile-flock-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-flock-perl/current/README?rev=64955&op=file
==============================================================================
--- branches/upstream/libfile-flock-perl/current/README (added)
+++ branches/upstream/libfile-flock-perl/current/README Wed Nov 17 10:51:29 2010
@@ -1,0 +1,18 @@
+
+File::Flock is a wrapper around the flock() call. The only thing it
+does that is special is that it creates the lock file if the lock file
+does not already exist.
+
+It will also try to remove the lock file. This makes it a bit
+complicated.
+
+To install File::Flock use the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+Under perl5.002, the make test will emit some warnings about "9" and
+"99" not being numeric values. I believe this is a bug in perl.
+
Added: branches/upstream/libfile-flock-perl/current/lib/File/Flock.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-flock-perl/current/lib/File/Flock.pm?rev=64955&op=file
==============================================================================
--- branches/upstream/libfile-flock-perl/current/lib/File/Flock.pm (added)
+++ branches/upstream/libfile-flock-perl/current/lib/File/Flock.pm Wed Nov 17 10:51:29 2010
@@ -1,0 +1,327 @@
+# Copyright (C) 1996, 1998 David Muir Sharnoff
+
+package File::Flock;
+
+require Exporter;
+ at ISA = qw(Exporter);
+ at EXPORT = qw(lock unlock lock_rename);
+
+use Carp;
+use POSIX qw(EAGAIN EACCES EWOULDBLOCK ENOENT EEXIST O_EXCL O_CREAT O_RDWR);
+use Fcntl qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN);
+use IO::File;
+
+use vars qw($VERSION $debug $av0debug);
+
+BEGIN {
+ $VERSION = 2008.01;
+ $debug = 0;
+ $av0debug = 0;
+}
+
+use strict;
+no strict qw(refs);
+
+my %locks; # did we create the file?
+my %lockHandle;
+my %shared;
+my %pid;
+my %rm;
+
+sub new
+{
+ my ($pkg, $file, $shared, $nonblocking) = @_;
+ &lock($file, $shared, $nonblocking) or return undef;
+ return bless \$file, $pkg;
+}
+
+sub DESTROY
+{
+ my ($this) = @_;
+ unlock($$this);
+}
+
+sub lock
+{
+ my ($file, $shared, $nonblocking) = @_;
+
+ my $f = new IO::File;
+
+ my $created = 0;
+ my $previous = exists $locks{$file};
+
+ # the file may be springing in and out of existance...
+ OPEN:
+ for(;;) {
+ if (-e $file) {
+ unless (sysopen($f, $file, O_RDWR)) {
+ redo OPEN if $! == ENOENT;
+ croak "open $file: $!";
+ }
+ } else {
+ unless (sysopen($f, $file, O_CREAT|O_EXCL|O_RDWR)) {
+ redo OPEN if $! == EEXIST;
+ croak "open >$file: $!";
+ }
+ print STDERR " {$$ " if $debug; # }
+ $created = 1;
+ }
+ last;
+ }
+ $locks{$file} = $created || $locks{$file} || 0;
+ $shared{$file} = $shared;
+ $pid{$file} = $$;
+
+ $lockHandle{$file} = $f;
+
+ my $flags;
+
+ $flags = $shared ? LOCK_SH : LOCK_EX;
+ $flags |= LOCK_NB
+ if $nonblocking;
+
+ local($0) = "$0 - locking $file" if $av0debug && ! $nonblocking;
+ my $r = flock($f, $flags);
+
+ print STDERR " ($$ " if $debug and $r;
+
+ if ($r) {
+ # let's check to make sure the file wasn't
+ # removed on us!
+
+ my $ifile = (stat($file))[1];
+ my $ihandle;
+ eval { $ihandle = (stat($f))[1] };
+ croak $@ if $@;
+
+ return 1 if defined $ifile
+ and defined $ihandle
+ and $ifile == $ihandle;
+
+ # oh well, try again
+ flock($f, LOCK_UN);
+ close($f);
+ return File::Flock::lock($file);
+ }
+
+ return 1 if $r;
+ if ($nonblocking and
+ (($! == EAGAIN)
+ or ($! == EACCES)
+ or ($! == EWOULDBLOCK)))
+ {
+ if (! $previous) {
+ delete $locks{$file};
+ delete $lockHandle{$file};
+ delete $shared{$file};
+ delete $pid{$file};
+ }
+ if ($created) {
+ # oops, a bad thing just happened.
+ # We don't want to block, but we made the file.
+ &background_remove($f, $file);
+ }
+ close($f);
+ return 0;
+ }
+ croak "flock $f $flags: $!";
+}
+
+#
+# get a lock on a file and remove it if it's empty. This is to
+# remove files that were created just so that they could be locked.
+#
+# To do this without blocking, defer any files that are locked to the
+# the END block.
+#
+sub background_remove
+{
+ my ($f, $file) = @_;
+
+ if (flock($f, LOCK_EX|LOCK_NB)) {
+ unlink($file)
+ if -s $file == 0;
+ flock($f, LOCK_UN);
+ return 1;
+ } else {
+ $rm{$file} = 1
+ unless exists $rm{$file};
+ return 0;
+ }
+}
+
+sub unlock
+{
+ my ($file) = @_;
+
+ if (ref $file eq 'File::Flock') {
+ bless $file, 'UNIVERSAL'; # avoid destructor later
+ $file = $$file;
+ }
+
+ croak "no lock on $file" unless exists $locks{$file};
+ my $created = $locks{$file};
+ my $unlocked = 0;
+
+
+ my $size = -s $file;
+ if ($created && defined($size) && $size == 0) {
+ if ($shared{$file}) {
+ $unlocked =
+ &background_remove($lockHandle{$file}, $file);
+ } else {
+ # {
+ print STDERR " $$} " if $debug;
+ unlink($file)
+ or croak "unlink $file: $!";
+ }
+ }
+ delete $locks{$file};
+ delete $pid{$file};
+
+ my $f = $lockHandle{$file};
+
+ delete $lockHandle{$file};
+
+ return 0 unless defined $f;
+
+ print STDERR " $$) " if $debug;
+ $unlocked or flock($f, LOCK_UN)
+ or croak "flock $file UN: $!";
+
+ close($f);
+ return 1;
+}
+
+sub lock_rename
+{
+ my ($oldfile, $newfile) = @_;
+
+ if (exists $locks{$newfile}) {
+ unlock $newfile;
+ }
+ delete $locks{$newfile};
+ delete $shared{$newfile};
+ delete $pid{$newfile};
+ delete $lockHandle{$newfile};
+ delete $rm{$newfile};
+
+ $locks{$newfile} = $locks{$oldfile} if exists $locks{$oldfile};
+ $shared{$newfile} = $shared{$oldfile} if exists $shared{$oldfile};
+ $pid{$newfile} = $pid{$oldfile} if exists $pid{$oldfile};
+ $lockHandle{$newfile} = $lockHandle{$oldfile} if exists $lockHandle{$oldfile};
+ $rm{$newfile} = $rm{$oldfile} if exists $rm{$oldfile};
+
+ delete $locks{$oldfile};
+ delete $shared{$oldfile};
+ delete $pid{$oldfile};
+ delete $lockHandle{$oldfile};
+ delete $rm{$oldfile};
+}
+
+#
+# Unlock any files that are still locked and remove any files
+# that were created just so that they could be locked.
+#
+END {
+ my $f;
+ for $f (keys %locks) {
+ &unlock($f)
+ if $pid{$f} == $$;
+ }
+
+ my %bgrm;
+ for my $file (keys %rm) {
+ my $f = new IO::File;
+ if (sysopen($f, $file, O_RDWR)) {
+ if (flock($f, LOCK_EX|LOCK_NB)) {
+ unlink($file)
+ if -s $file == 0;
+ flock($f, LOCK_UN);
+ } else {
+ $bgrm{$file} = 1;
+ }
+ close($f);
+ }
+ }
+ if (%bgrm) {
+ my $ppid = fork;
+ croak "cannot fork" unless defined $ppid;
+ my $pppid = $$;
+ my $b0 = $0;
+ $0 = "$b0: waiting for child ($ppid) to fork()";
+ unless ($ppid) {
+ my $pid = fork;
+ croak "cannot fork" unless defined $pid;
+ unless ($pid) {
+ for my $file (keys %bgrm) {
+ my $f = new IO::File;
+ if (sysopen($f, $file, O_RDWR)) {
+ if (flock($f, LOCK_EX)) {
+ unlink($file)
+ if -s $file == 0;
+ flock($f, LOCK_UN);
+ }
+ close($f);
+ }
+ }
+ print STDERR " $pppid] $pppid)" if $debug;
+ }
+ kill(9, $$); # exit w/o END or anything else
+ }
+ waitpid($ppid, 0);
+ kill(9, $$); # exit w/o END or anything else
+ }
+}
+
+1;
+
+__DATA__
+
+=head1 NAME
+
+ File::Flock - file locking with flock
+
+=head1 SYNOPSIS
+
+ use File::Flock;
+
+ lock($filename);
+
+ lock($filename, 'shared');
+
+ lock($filename, undef, 'nonblocking');
+
+ lock($filename, 'shared', 'nonblocking');
+
+ unlock($filename);
+
+ my $lock = new File::Flock '/somefile';
+
+ lock_rename($oldfilename, $newfilename)
+
+=head1 DESCRIPTION
+
+Lock files using the flock() call. If the file to be locked does not
+exist, then the file is created. If the file was created then it will
+be removed when it is unlocked assuming it's still an empty file.
+
+Locks can be created by new'ing a B<File::Flock> object. Such locks
+are automatically removed when the object goes out of scope. The
+B<unlock()> method may also be used.
+
+B<lock_rename()> is used to tell File::Flock when a file has been
+renamed (and thus the internal locking data that is stored based
+on the filename should be moved to a new name). B<unlock()> the
+new name rather than the original name.
+
+=head1 LICENSE
+
+File::Flock may be used/modified/distibuted on the same terms
+as perl itself.
+
+=head1 AUTHOR
+
+David Muir Sharnoff <muir at idiom.org>
+
+
Added: branches/upstream/libfile-flock-perl/current/t/flock.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-flock-perl/current/t/flock.t?rev=64955&op=file
==============================================================================
--- branches/upstream/libfile-flock-perl/current/t/flock.t (added)
+++ branches/upstream/libfile-flock-perl/current/t/flock.t Wed Nov 17 10:51:29 2010
@@ -1,0 +1,284 @@
+#!/usr/bin/perl5.00502 -w -I.
+
+$counter = "/tmp/flt1.$$";
+$lock = "/tmp/flt2.$$";
+$lock2 = "/tmp/flt3.$$";
+$lock3 = "/tmp/flt4.$$";
+$lock4 = "/tmp/flt5.$$";
+$lock5 = "/tmp/flt6.$$";
+$lock6 = "/tmp/flt7.$$";
+$lock7 = "/tmp/flt8.$$";
+
+use File::Flock;
+use Carp;
+use FileHandle;
+
+STDOUT->autoflush(1);
+
+$children = 6;
+$count = 120;
+die unless $count % 2 == 0;
+die unless $count % 3 == 0;
+print "1..".($count*1.5+$children*2+7)."\n";
+
+my $child = 0;
+my $i;
+for $i (1..$children) {
+ $p = fork();
+ croak unless defined $p;
+ $parent = $p or $child = $i;
+ last unless $parent;
+}
+
+STDOUT->autoflush(1);
+
+if ($parent) {
+ print "ok 1\n";
+ &write_file($counter, "2");
+ &write_file($lock, "");
+ &write_file($lock4, "");
+ lock($lock4);
+} else {
+ my $e;
+ while (! -e $lock) {
+ # spin
+ die if $e++ > 1000000;
+ }
+ lock($lock3, 'shared');
+}
+
+lock($lock2, 'shared');
+
+my $c;
+my $ee;
+while (($c = &read_file($counter)) < $count) {
+ die if $ee++ > 10000000;
+ if ($c < $count*.25 || $c > $count*.75) {
+ lock($lock);
+ } else {
+ lock($lock, 0, 1) || next;
+ }
+ $c = &read_file($counter);
+
+ # make sure each child increments it at least once.
+ if ($c < $children+2 && $c != $child+2) {
+ unlock($lock);
+ next;
+ }
+
+ if ($c < $count) {
+ print "ok $c\n";
+ $c++;
+ &overwrite_file($counter, "$c");
+ }
+
+ # one of the children will exit (and thus need to clean up)
+ if ($c == $count/3) {
+ exit(0) if fork() == 0;
+ }
+
+ # deal with a missing lock file
+ if ($c == $count/2) {
+ unlink($lock)
+ or croak "unlink $lock: $!";
+ }
+
+ # make sure the lock file doesn't get deleted
+ if ($c == int($count*.9)) {
+ &overwrite_file($lock, "keepme");
+ }
+
+ unlock($lock);
+}
+
+lock($lock);
+$c = &read_file($counter);
+print "ok $c\n";
+$c++;
+&overwrite_file($counter, "$c");
+unlock($lock);
+
+if ($c == $count+$children+1) {
+ print "ok $c\n";
+ $c++;
+ if (&read_file($lock) eq 'keepme')
+ {print "ok $c\n";} else {print "not ok $c\n"};
+ unlink($lock);
+ $c++;
+}
+
+unlock($lock2);
+
+if ($parent) {
+ lock($lock2);
+ unlock($lock2);
+
+ $c = $count+$children+3;
+
+ &write_file($counter, $c);
+ unlock($lock4);
+}
+
+
+# okay, now that that's all done, lets try some locks using
+# the object interface...
+
+my $start = $c;
+
+for(;;) {
+ my $l = new File::Flock $lock4;
+
+ $c = &read_file($counter);
+
+ last if $c > $count/2+$start;
+
+ print "ok $c\n";
+ $c++;
+ &overwrite_file($counter, "$c");
+}
+#
+# now let's make sure nonblocking works
+#
+if ($parent) {
+ my $e;
+ lock $lock6;
+ for(;;) {
+ lock($lock7, undef, 'nonblocking')
+ or last;
+ unlock($lock7);
+ die if $e++ > 1000;
+ sleep(1);
+ }
+ unlock $lock6;
+ lock $counter;
+ $c = &read_file($counter);
+ print "ok $c\n";
+ $c++;
+ &overwrite_file($counter, "$c");
+ unlock $counter;
+
+} elsif ($child == 1) {
+ my $e;
+ for(;;) {
+ lock($lock6, undef, 'nonblocking')
+ or last;
+ unlock($lock6);
+ die if $e++ > 1000;
+ sleep(1);
+ }
+ lock $lock7;
+ lock $lock6;
+ lock $counter;
+ $c = &read_file($counter);
+ print "ok $c\n";
+ $c++;
+ &overwrite_file($counter, "$c");
+ unlock $counter;
+ unlock $lock7;
+ unlock $lock6;
+}
+
+#
+# Shut everything down
+#
+if ($parent) {
+ my $l = new File::Flock $lock3;
+ $c = &read_file($counter);
+ if ($l) { print "ok $c\n" } else {print "not ok $c\n"}
+ $c++;
+ unlink($counter);
+ unlink($lock4);
+ unlink($lock);
+ lock($lock5);
+ unlock($lock5);
+ if (-e $lock5) { print "not ok $c\n" } else {print "ok $c\n"}
+ $c++;
+ $x = '';
+ for (1..$children) {
+ wait();
+ $status = $? >> 8;
+ if ($status) { $x .= "not ok $c\n";} else {$x .= "ok $c\n"}
+ $c++;
+ }
+ $l->unlock();
+ print $x;
+} else {
+ unlock($lock3);
+}
+exit(0);
+
+sub read_file
+{
+ my ($file) = @_;
+
+ local(*F);
+ my $r;
+ my (@r);
+
+ open(F, "<$file") || croak "open $file: $!";
+ @r = <F>;
+ close(F);
+
+ return @r if wantarray;
+ return join("", at r);
+}
+
+sub write_file
+{
+ my ($f, @data) = @_;
+
+ local(*F);
+
+ open(F, ">$f") || croak "open >$f: $!";
+ (print F @data) || croak "write $f: $!";
+ close(F) || croak "close $f: $!";
+ return 1;
+}
+
+sub overwrite_file
+{
+ my ($f, @data) = @_;
+
+ local(*F);
+
+ if (-e $f) {
+ open(F, "+<$f") || croak "open +<$f: $!";
+ } else {
+ open(F, "+>$f") || croak "open >$f: $!";
+ }
+ (print F @data) || croak "write $f: $!";
+ my $where = tell(F);
+ croak "could not tell($f): $!"
+ unless defined $where;
+ truncate(F, $where)
+ || croak "trucate $f at $where: $!";
+ close(F) || croak "close $f: $!";
+ return 1;
+}
+
+sub append_file
+{
+ my ($f, @data) = @_;
+
+ local(*F);
+
+ open(F, ">>$f") || croak "open >>$f: $!";
+ (print F @data) || croak "write $f: $!";
+ close(F) || croak "close $f: $!";
+ return 1;
+}
+
+sub read_dir
+{
+ my ($d) = @_;
+
+ my (@r);
+ local(*D);
+
+ opendir(D,$d) || croak "opendir $d: $!";
+ @r = grep($_ ne "." && $_ ne "..", readdir(D));
+ closedir(D);
+ return @r;
+}
+
+1;
Propchange: branches/upstream/libfile-flock-perl/current/t/flock.t
------------------------------------------------------------------------------
svn:executable =
More information about the Pkg-perl-cvs-commits
mailing list