r31582 - in /branches/upstream/libfile-counterfile-perl: ./ current/ current/Changes current/CounterFile.pm current/MANIFEST current/Makefile.PL current/README current/t/ current/t/basic.t current/t/race.t
ryan52-guest at users.alioth.debian.org
ryan52-guest at users.alioth.debian.org
Sat Mar 7 02:01:11 UTC 2009
Author: ryan52-guest
Date: Sat Mar 7 02:01:08 2009
New Revision: 31582
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=31582
Log:
[svn-inject] Installing original source of libfile-counterfile-perl
Added:
branches/upstream/libfile-counterfile-perl/
branches/upstream/libfile-counterfile-perl/current/
branches/upstream/libfile-counterfile-perl/current/Changes
branches/upstream/libfile-counterfile-perl/current/CounterFile.pm
branches/upstream/libfile-counterfile-perl/current/MANIFEST
branches/upstream/libfile-counterfile-perl/current/Makefile.PL
branches/upstream/libfile-counterfile-perl/current/README
branches/upstream/libfile-counterfile-perl/current/t/
branches/upstream/libfile-counterfile-perl/current/t/basic.t
branches/upstream/libfile-counterfile-perl/current/t/race.t
Added: branches/upstream/libfile-counterfile-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-counterfile-perl/current/Changes?rev=31582&op=file
==============================================================================
--- branches/upstream/libfile-counterfile-perl/current/Changes (added)
+++ branches/upstream/libfile-counterfile-perl/current/Changes Sat Mar 7 02:01:08 2009
@@ -1,0 +1,69 @@
+2004-01-23 Gisle Aas <gisle at activestate.com>
+
+ Release 1.04
+
+ Restore compatibility with perl5.004 and perl5.005.
+
+
+
+2004-01-08 Gisle Aas <gisle at activestate.com>
+
+ Release 1.03
+
+ Documentation fixes by Paul Croome <Paul.Croome at softwareag.com>.
+
+ Use more Fcntl constants instead of hardcoded values.
+
+
+
+2003-11-21 Gisle Aas <gisle at activestate.com>
+
+ Release 1.02
+
+ Gurusamy Sarathy found that the 'race' test failed on platforms
+ which don't manage to autoflush before fork. The workaround
+ applied is to enable perl level autoflush in that test script.
+
+
+
+2003-10-06 Gisle Aas <gisle at activestate.com>
+
+ Release 1.01
+
+ Various fixes by Jan Dubois to make the module work better on Windows.
+
+ - Unlock the file before croak()ing in dec() method
+ - seek() after reading to EOF. Otherwise we cannot write (on Windows)
+ - unlink() counterfile at the beginning of tests to protect against
+ leftovers from previous failures
+ - test for fork() availability in race.t
+ - warn on failed unlink() because Windows will not unlink open files
+
+
+
+2002-07-30 Gisle Aas <gisle at activestate.com>
+
+ Release 1.00
+
+ Fix possible race condition if multiple processes tries to create
+ the counter file at the same time. Based on patch from
+ Philipp Gühring <p.guehring at futureware.at>.
+
+
+
+1998-06-09 Gisle Aas <aas at sn.no>
+
+ Release 0.12
+
+
+
+1998-05-16 Gisle Aas <aas at sn.no>
+
+ Fix problem with 'Ambiguous use of {value} resolved to {"value"}' warnings
+ when the module is reloaded.
+
+
+
+1998-03-25 Gisle Aas <aas at sn.no>
+
+ Release 0.11, unbundled from libwww-perl-5.22.
Added: branches/upstream/libfile-counterfile-perl/current/CounterFile.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-counterfile-perl/current/CounterFile.pm?rev=31582&op=file
==============================================================================
--- branches/upstream/libfile-counterfile-perl/current/CounterFile.pm (added)
+++ branches/upstream/libfile-counterfile-perl/current/CounterFile.pm Sat Mar 7 02:01:08 2009
@@ -1,0 +1,261 @@
+package File::CounterFile;
+
+# $Id: CounterFile.pm,v 0.23 2004/01/23 08:37:18 gisle Exp $
+
+require 5.004;
+
+use strict;
+
+use Carp qw(croak);
+use Symbol qw(gensym);
+use Fcntl qw(LOCK_EX O_RDWR O_CREAT);
+
+BEGIN {
+ # older version of Fcntl did not know about SEEK_SET
+ if ($] < 5.006) {
+ *SEEK_SET = sub () { 0 };
+ }
+ else {
+ Fcntl->import("SEEK_SET");
+ }
+}
+
+use vars qw($VERSION $MAGIC $DEFAULT_INITIAL $DEFAULT_DIR);
+
+sub Version { $VERSION; }
+$VERSION = "1.04";
+
+$MAGIC = "#COUNTER-1.0\n"; # first line in counter files
+$DEFAULT_INITIAL = 0; # default initial counter value
+
+ # default location for counter files
+$DEFAULT_DIR = $ENV{TMPDIR} || "/usr/tmp";
+
+# Experimental overloading.
+use overload ('++' => \&inc,
+ '--' => \&dec,
+ '""' => \&value,
+ fallback => 1,
+ );
+
+
+sub new
+{
+ my($class, $file, $initial) = @_;
+ croak("No file specified\n") unless defined $file;
+
+ $file = "$DEFAULT_DIR/$file" unless $file =~ /^[\.\/]/;
+ $initial = $DEFAULT_INITIAL unless defined $initial;
+
+ my $value;
+ local($/, $\) = ("\n", undef);
+ local *F;
+ sysopen(F, $file, O_RDWR|O_CREAT) or croak("Can't open $file: $!");
+ flock(F, LOCK_EX) or croak("Can't flock: $!");
+ my $first_line = <F>;
+ if (defined $first_line) {
+ croak "Bad counter magic '$first_line' in $file" unless $first_line eq $MAGIC;
+ $value = <F>;
+ chomp($value);
+ }
+ else {
+ seek(F, 0, SEEK_SET);
+ print F $MAGIC;
+ print F "$initial\n";
+ $value = $initial;
+ }
+ close(F) || croak("Can't close $file: $!");
+
+ bless { file => $file, # the filename for the counter
+ 'value' => $value, # the current value
+ updated => 0, # flag indicating if value has changed
+ # handle => XXX, # file handle symbol. Only present when locked
+ };
+}
+
+
+sub locked
+{
+ exists shift->{handle};
+}
+
+
+sub lock
+{
+ my($self) = @_;
+ $self->unlock if $self->locked;
+
+ my $fh = gensym();
+ my $file = $self->{file};
+
+ open($fh, "+<$file") or croak "Can't open $file: $!";
+ flock($fh, LOCK_EX) or croak "Can't flock: $!"; # 2 = exlusive lock
+
+ local($/) = "\n";
+ my $magic = <$fh>;
+ if ($magic ne $MAGIC) {
+ $self->unlock;
+ croak("Bad counter magic '$magic' in $file");
+ }
+ chomp($self->{'value'} = <$fh>);
+
+ $self->{handle} = $fh;
+ $self->{updated} = 0;
+ $self;
+}
+
+
+sub unlock
+{
+ my($self) = @_;
+ return unless $self->locked;
+
+ my $fh = $self->{handle};
+
+ if ($self->{updated}) {
+ # write back new value
+ local($\) = undef;
+ seek($fh, 0, SEEK_SET) or croak "Can't seek to beginning: $!";
+ print $fh $MAGIC;
+ print $fh "$self->{'value'}\n";
+ }
+
+ close($fh) or warn "Can't close: $!";
+ delete $self->{handle};
+ $self;
+}
+
+
+sub inc
+{
+ my($self) = @_;
+
+ if ($self->locked) {
+ $self->{'value'}++;
+ $self->{updated} = 1;
+ } else {
+ $self->lock;
+ $self->{'value'}++;
+ $self->{updated} = 1;
+ $self->unlock;
+ }
+ $self->{'value'}; # return value
+}
+
+
+sub dec
+{
+ my($self) = @_;
+
+ if ($self->locked) {
+ unless ($self->{'value'} =~ /^\d+$/) {
+ $self->unlock;
+ croak "Autodecrement is not magical in perl";
+ }
+ $self->{'value'}--;
+ $self->{updated} = 1;
+ }
+ else {
+ $self->lock;
+ unless ($self->{'value'} =~ /^\d+$/) {
+ $self->unlock;
+ croak "Autodecrement is not magical in perl";
+ }
+ $self->{'value'}--;
+ $self->{updated} = 1;
+ $self->unlock;
+ }
+ $self->{'value'}; # return value
+}
+
+
+sub value
+{
+ my($self) = @_;
+ my $value;
+ if ($self->locked) {
+ $value = $self->{'value'};
+ }
+ else {
+ $self->lock;
+ $value = $self->{'value'};
+ $self->unlock;
+ }
+ $value;
+}
+
+
+sub DESTROY
+{
+ my $self = shift;
+ $self->unlock;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::CounterFile - Persistent counter class
+
+=head1 SYNOPSIS
+
+ use File::CounterFile;
+ $c = File::CounterFile->new("COUNTER", "aa00");
+
+ $id = $c->inc;
+ open(F, ">F$id");
+
+=head1 DESCRIPTION
+
+This module implements a persistent counter class. Each counter is
+represented by a separate file in the file system. File locking is
+applied, so multiple processes can attempt to access a counter
+simultaneously without risk of counter destruction.
+
+You give the file name as the first parameter to the object
+constructor (C<new>). The file is created if it does not exist.
+
+If the file name does not start with "/" or ".", then it is
+interpreted as a file relative to C<$File::CounterFile::DEFAULT_DIR>.
+The default value for this variable is initialized from the
+environment variable C<TMPDIR>, or F</usr/tmp> if no environment
+variable is defined. You may want to assign a different value to this
+variable before creating counters.
+
+If you pass a second parameter to the constructor, it sets the
+initial value for a new counter. This parameter only takes effect
+when the file is created (i.e. it does not exist before the call).
+
+When you call the C<inc()> method, you increment the counter value by
+one. When you call C<dec()>, the counter value is decremented. In both
+cases the new value is returned. The C<dec()> method only works for
+numerical counters (digits only).
+
+You can peek at the value of the counter (without incrementing it) by
+using the C<value()> method.
+
+The counter can be locked and unlocked with the C<lock()> and
+C<unlock()> methods. Incrementing and value retrieval are faster when
+the counter is locked, because we do not have to update the counter
+file all the time. You can query whether the counter is locked with
+the C<locked()> method.
+
+There is also an operator overloading interface to the
+File::CounterFile object. This means that you can use the C<++>
+operator for incrementing and the C<--> operator for decrementing the counter,
+and you can interpolate counters directly into strings.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-1998,2002,2003 Gisle Aas. All rights reserved.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Gisle Aas <gisle at aas.no>
+
+=cut
Added: branches/upstream/libfile-counterfile-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-counterfile-perl/current/MANIFEST?rev=31582&op=file
==============================================================================
--- branches/upstream/libfile-counterfile-perl/current/MANIFEST (added)
+++ branches/upstream/libfile-counterfile-perl/current/MANIFEST Sat Mar 7 02:01:08 2009
@@ -1,0 +1,7 @@
+Changes
+CounterFile.pm
+MANIFEST
+Makefile.PL
+README
+t/basic.t
+t/race.t
Added: branches/upstream/libfile-counterfile-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-counterfile-perl/current/Makefile.PL?rev=31582&op=file
==============================================================================
--- branches/upstream/libfile-counterfile-perl/current/Makefile.PL (added)
+++ branches/upstream/libfile-counterfile-perl/current/Makefile.PL Sat Mar 7 02:01:08 2009
@@ -1,0 +1,8 @@
+require 5.004;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'File::CounterFile',
+ VERSION_FROM => 'CounterFile.pm',
+ dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+);
Added: branches/upstream/libfile-counterfile-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-counterfile-perl/current/README?rev=31582&op=file
==============================================================================
--- branches/upstream/libfile-counterfile-perl/current/README (added)
+++ branches/upstream/libfile-counterfile-perl/current/README Sat Mar 7 02:01:08 2009
@@ -1,0 +1,56 @@
+NAME
+ File::CounterFile - Persistent counter class
+
+SYNOPSIS
+ use File::CounterFile;
+ $c = File::CounterFile->new("COUNTER", "aa00");
+
+ $id = $c->inc;
+ open(F, ">F$id");
+
+DESCRIPTION
+ This module implements a persistent counter class. Each counter is
+ represented by a separate file in the file system. File locking is
+ applied, so multiple processes might try to access the same counters at
+ the same time without risk of counter destruction.
+
+ You give the file name as the first parameter to the object constructor
+ ("new"). The file is created if it does not exist.
+
+ If the file name does not start with "/" or ".", then it is interpreted
+ as a file relative to $File::CounterFile::DEFAULT_DIR. The default value
+ for this variable is initialized from the environment variable "TMPDIR",
+ or /usr/tmp is no environment variable is defined. You may want to
+ assign a different value to this variable before creating counters.
+
+ If you pass a second parameter to the constructor, that sets the initial
+ value for a new counter. This parameter only takes effect when the file
+ is created (i.e. it does not exist before the call).
+
+ When you call the "inc()" method, you increment the counter value by
+ one. When you call "dec()" the counter value is decrementd. In both
+ cases the new value is returned. The "dec()" method only works for
+ numerical counters (digits only).
+
+ You can peek at the value of the counter (without incrementing it) by
+ using the "value()" method.
+
+ The counter can be locked and unlocked with the "lock()" and "unlock()"
+ methods. Incrementing and value retrieval is faster when the counter is
+ locked, because we do not have to update the counter file all the time.
+ You can query whether the counter is locked with the "locked()" method.
+
+ There is also an operator overloading interface to the File::CounterFile
+ object. This means that you might use the "++" operator for incrementing
+ the counter, "--" operator for decrementing and you can interpolate
+ counters diretly into strings.
+
+COPYRIGHT
+ Copyright (c) 1995-1998,2002,2003 Gisle Aas. All rights reserved.
+
+ This library is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
+AUTHOR
+ Gisle Aas <gisle at aas.no>
+
Added: branches/upstream/libfile-counterfile-perl/current/t/basic.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-counterfile-perl/current/t/basic.t?rev=31582&op=file
==============================================================================
--- branches/upstream/libfile-counterfile-perl/current/t/basic.t (added)
+++ branches/upstream/libfile-counterfile-perl/current/t/basic.t Sat Mar 7 02:01:08 2009
@@ -1,0 +1,63 @@
+#!/usr/bin/perl -w
+
+print "1..1\n";
+
+use strict;
+use File::CounterFile;
+
+my $cf = "./zz-counter-$$"; # the name for out temprary counter
+
+# Test normal object creation and increment
+
+unlink $cf;
+my $c = new File::CounterFile $cf;
+
+my $id1 = $c->inc;
+my $id2 = $c->inc;
+
+$c = new File::CounterFile $cf;
+my $id3 = $c->inc;
+my $id4 = $c->dec;
+
+die "test failed" unless ($id1 == 1 && $id2 == 2 && $id3 == 3 && $id4 == 2);
+unlink $cf or die "Can't unlink $cf: $!";
+
+# Test magic increment
+
+$id1 = (new File::CounterFile $cf, "aa98")->inc;
+$id2 = (new File::CounterFile $cf)->inc;
+$id3 = (new File::CounterFile $cf)->inc;
+
+eval {
+ # This should now work because "Decrement is not magical in perl"
+ $c = new File::CounterFile $cf; $id4 = $c->dec; $c = undef;
+};
+die "test failed (No exception to catch)" unless $@;
+
+#print "$id1 $id2 $id3\n";
+
+die "test failed" unless ($id1 eq "aa99" && $id2 eq "ab00" && $id3 eq "ab01");
+unlink $cf or die "Can't unlink $cf: $!";
+
+# Test operator overloading
+
+$c = new File::CounterFile $cf, "100";
+
+$c->lock;
+
+$c++; # counter is now 101
+$c++; # counter is now 102
+$c++; # counter is now 103
+$c--; # counter is now 102 again
+
+$id1 = "$c";
+$id2 = ++$c;
+
+$c = undef; # destroy object
+
+unlink $cf;
+
+die "test failed" unless $id1 == 102 && $id2 == 103;
+
+print "# Selftest for File::CounterFile $File::CounterFile::VERSION ok\n";
+print "ok 1\n";
Added: branches/upstream/libfile-counterfile-perl/current/t/race.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-counterfile-perl/current/t/race.t?rev=31582&op=file
==============================================================================
--- branches/upstream/libfile-counterfile-perl/current/t/race.t (added)
+++ branches/upstream/libfile-counterfile-perl/current/t/race.t Sat Mar 7 02:01:08 2009
@@ -1,0 +1,58 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ # copied from t/op/fork.t from Perl 5.8.0:
+ require Config; import Config;
+ unless ($Config{'d_fork'}
+ or (($^O eq 'MSWin32' || $^O eq 'NetWare') and $Config{useithreads}
+ and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
+ ))
+ {
+ print "1..0 # Skip: no fork\n";
+ exit 0;
+ }
+}
+
+use strict;
+use File::CounterFile;
+my $counter = "./zz-counter-$$";
+unlink($counter);
+
+$| = 1;
+
+my $num_rounds = 100;
+my $num_kids = 10;
+my $num_incs = 10;
+
+print "1..$num_rounds\n";
+
+for my $round (1 .. $num_rounds) {
+ for (1 .. $num_kids) {
+ my $kid = fork();
+ die "Can't fork: $!" unless defined $kid;
+ next if $kid;
+
+ #print "Child $$\n";
+ #select(undef, undef, undef, 0.01);
+ my $c = File::CounterFile->new($counter);
+ for (1 .. $num_incs) {
+ #select(undef, undef, undef, 0.01);
+ my $v = $c->inc;
+ #print "$$: $v\n";
+ }
+ exit;
+ }
+
+ for (1 .. $num_kids) {
+ my $pid = wait;
+ die "Can't wait: $!" if $pid == -1;
+ #print "Kid $pid done\n";
+ }
+ #print "All done\n";
+
+ my $c = File::CounterFile->new($counter);
+ print "not " unless $c->value == $num_kids * $num_incs;
+ print "ok $round\n";
+
+ unlink($counter) || warn "Can't unlink $counter: $!";
+}
More information about the Pkg-perl-cvs-commits
mailing list