File-CounterFile-1.04/0040755000076400007640000000000010004156540013531 5ustar gislegisleFile-CounterFile-1.04/README0100644000076400007640000000446607740262214014431 0ustar gislegisleNAME 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 File-CounterFile-1.04/Makefile.PL0100644000076400007640000000030407521514626015512 0ustar gislegislerequire 5.004; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'File::CounterFile', VERSION_FROM => 'CounterFile.pm', dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, ); File-CounterFile-1.04/Changes0100644000076400007640000000315210004156442015023 0ustar gislegisle2004-01-23 Gisle Aas Release 1.04 Restore compatibility with perl5.004 and perl5.005. 2004-01-08 Gisle Aas Release 1.03 Documentation fixes by Paul Croome . Use more Fcntl constants instead of hardcoded values. 2003-11-21 Gisle Aas 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 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 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 . 1998-06-09 Gisle Aas Release 0.12 1998-05-16 Gisle Aas Fix problem with 'Ambiguous use of {value} resolved to {"value"}' warnings when the module is reloaded. 1998-03-25 Gisle Aas Release 0.11, unbundled from libwww-perl-5.22. File-CounterFile-1.04/CounterFile.pm0100644000076400007640000001357610004156476016327 0ustar gislegislepackage 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 = ; if (defined $first_line) { croak "Bad counter magic '$first_line' in $file" unless $first_line eq $MAGIC; $value = ; 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). 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, or F 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 method, you increment the counter value by one. When you call C, the counter value is decremented. In both cases the new value is returned. The C method only works for numerical counters (digits only). You can peek at the value of the counter (without incrementing it) by using the C method. The counter can be locked and unlocked with the C and C 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 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 =cut File-CounterFile-1.04/MANIFEST0100644000076400007640000000010607777245304014700 0ustar gislegisleChanges CounterFile.pm MANIFEST Makefile.PL README t/basic.t t/race.t File-CounterFile-1.04/t/0040755000076400007640000000000010004156540013774 5ustar gislegisleFile-CounterFile-1.04/t/race.t0100644000076400007640000000230707757357662015127 0ustar gislegisle#!/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: $!"; } File-CounterFile-1.04/t/basic.t0100644000076400007640000000254507740261271015260 0ustar gislegisle#!/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";