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