1package File::CounterFile; 2 3# $Id: CounterFile.pm,v 0.23 2004/01/23 08:37:18 gisle Exp $ 4 5require 5.004; 6 7use strict; 8 9use Carp qw(croak); 10use Symbol qw(gensym); 11use Fcntl qw(LOCK_EX O_RDWR O_CREAT); 12 13BEGIN { 14 # older version of Fcntl did not know about SEEK_SET 15 if ($] < 5.006) { 16 *SEEK_SET = sub () { 0 }; 17 } 18 else { 19 Fcntl->import("SEEK_SET"); 20 } 21} 22 23use vars qw($VERSION $MAGIC $DEFAULT_INITIAL $DEFAULT_DIR); 24 25sub Version { $VERSION; } 26$VERSION = "1.04"; 27 28$MAGIC = "#COUNTER-1.0\n"; # first line in counter files 29$DEFAULT_INITIAL = 0; # default initial counter value 30 31 # default location for counter files 32$DEFAULT_DIR = $ENV{TMPDIR} || "/var/tmp"; 33 34# Experimental overloading. 35use overload ('++' => \&inc, 36 '--' => \&dec, 37 '""' => \&value, 38 fallback => 1, 39 ); 40 41 42sub new 43{ 44 my($class, $file, $initial) = @_; 45 croak("No file specified\n") unless defined $file; 46 47 $file = "$DEFAULT_DIR/$file" unless $file =~ /^[\.\/]/; 48 $initial = $DEFAULT_INITIAL unless defined $initial; 49 50 my $value; 51 local($/, $\) = ("\n", undef); 52 local *F; 53 sysopen(F, $file, O_RDWR|O_CREAT) or croak("Can't open $file: $!"); 54 flock(F, LOCK_EX) or croak("Can't flock: $!"); 55 my $first_line = <F>; 56 if (defined $first_line) { 57 croak "Bad counter magic '$first_line' in $file" unless $first_line eq $MAGIC; 58 $value = <F>; 59 chomp($value); 60 } 61 else { 62 seek(F, 0, SEEK_SET); 63 print F $MAGIC; 64 print F "$initial\n"; 65 $value = $initial; 66 } 67 close(F) || croak("Can't close $file: $!"); 68 69 bless { file => $file, # the filename for the counter 70 'value' => $value, # the current value 71 updated => 0, # flag indicating if value has changed 72 # handle => XXX, # file handle symbol. Only present when locked 73 }; 74} 75 76 77sub locked 78{ 79 exists shift->{handle}; 80} 81 82 83sub lock 84{ 85 my($self) = @_; 86 $self->unlock if $self->locked; 87 88 my $fh = gensym(); 89 my $file = $self->{file}; 90 91 open($fh, "+<$file") or croak "Can't open $file: $!"; 92 flock($fh, LOCK_EX) or croak "Can't flock: $!"; # 2 = exlusive lock 93 94 local($/) = "\n"; 95 my $magic = <$fh>; 96 if ($magic ne $MAGIC) { 97 $self->unlock; 98 croak("Bad counter magic '$magic' in $file"); 99 } 100 chomp($self->{'value'} = <$fh>); 101 102 $self->{handle} = $fh; 103 $self->{updated} = 0; 104 $self; 105} 106 107 108sub unlock 109{ 110 my($self) = @_; 111 return unless $self->locked; 112 113 my $fh = $self->{handle}; 114 115 if ($self->{updated}) { 116 # write back new value 117 local($\) = undef; 118 seek($fh, 0, SEEK_SET) or croak "Can't seek to beginning: $!"; 119 print $fh $MAGIC; 120 print $fh "$self->{'value'}\n"; 121 } 122 123 close($fh) or warn "Can't close: $!"; 124 delete $self->{handle}; 125 $self; 126} 127 128 129sub inc 130{ 131 my($self) = @_; 132 133 if ($self->locked) { 134 $self->{'value'}++; 135 $self->{updated} = 1; 136 } else { 137 $self->lock; 138 $self->{'value'}++; 139 $self->{updated} = 1; 140 $self->unlock; 141 } 142 $self->{'value'}; # return value 143} 144 145 146sub dec 147{ 148 my($self) = @_; 149 150 if ($self->locked) { 151 unless ($self->{'value'} =~ /^\d+$/) { 152 $self->unlock; 153 croak "Autodecrement is not magical in perl"; 154 } 155 $self->{'value'}--; 156 $self->{updated} = 1; 157 } 158 else { 159 $self->lock; 160 unless ($self->{'value'} =~ /^\d+$/) { 161 $self->unlock; 162 croak "Autodecrement is not magical in perl"; 163 } 164 $self->{'value'}--; 165 $self->{updated} = 1; 166 $self->unlock; 167 } 168 $self->{'value'}; # return value 169} 170 171 172sub value 173{ 174 my($self) = @_; 175 my $value; 176 if ($self->locked) { 177 $value = $self->{'value'}; 178 } 179 else { 180 $self->lock; 181 $value = $self->{'value'}; 182 $self->unlock; 183 } 184 $value; 185} 186 187 188sub DESTROY 189{ 190 my $self = shift; 191 $self->unlock; 192} 193 1941; 195 196__END__ 197 198=head1 NAME 199 200File::CounterFile - Persistent counter class 201 202=head1 SYNOPSIS 203 204 use File::CounterFile; 205 $c = File::CounterFile->new("COUNTER", "aa00"); 206 207 $id = $c->inc; 208 open(F, ">F$id"); 209 210=head1 DESCRIPTION 211 212This module implements a persistent counter class. Each counter is 213represented by a separate file in the file system. File locking is 214applied, so multiple processes can attempt to access a counter 215simultaneously without risk of counter destruction. 216 217You give the file name as the first parameter to the object 218constructor (C<new>). The file is created if it does not exist. 219 220If the file name does not start with "/" or ".", then it is 221interpreted as a file relative to C<$File::CounterFile::DEFAULT_DIR>. 222The default value for this variable is initialized from the 223environment variable C<TMPDIR>, or F</var/tmp> if no environment 224variable is defined. You may want to assign a different value to this 225variable before creating counters. 226 227If you pass a second parameter to the constructor, it sets the 228initial value for a new counter. This parameter only takes effect 229when the file is created (i.e. it does not exist before the call). 230 231When you call the C<inc()> method, you increment the counter value by 232one. When you call C<dec()>, the counter value is decremented. In both 233cases the new value is returned. The C<dec()> method only works for 234numerical counters (digits only). 235 236You can peek at the value of the counter (without incrementing it) by 237using the C<value()> method. 238 239The counter can be locked and unlocked with the C<lock()> and 240C<unlock()> methods. Incrementing and value retrieval are faster when 241the counter is locked, because we do not have to update the counter 242file all the time. You can query whether the counter is locked with 243the C<locked()> method. 244 245There is also an operator overloading interface to the 246File::CounterFile object. This means that you can use the C<++> 247operator for incrementing and the C<--> operator for decrementing the counter, 248and you can interpolate counters directly into strings. 249 250=head1 COPYRIGHT 251 252Copyright (c) 1995-1998,2002,2003 Gisle Aas. All rights reserved. 253 254This library is free software; you can redistribute it and/or 255modify it under the same terms as Perl itself. 256 257=head1 AUTHOR 258 259Gisle Aas <gisle@aas.no> 260 261=cut 262