1# This -*-perl -*- module implements a persistent counter class. 2# 3# $Id: CounterFile.pm,v 1.7 2007-08-09 13:40:53 pajamian Exp $ 4# 5 6package Vend::CounterFile; 7use Vend::Util; 8use POSIX qw/strftime/; 9 10 11=head1 NAME 12 13Vend::CounterFile - Persistent counter class 14 15=head1 SYNOPSIS 16 17 use Vend::CounterFile; 18 $c = new Vend::CounterFile "COUNTER", "aa00"; 19 20 $id = $c->inc; 21 open(F, ">F$id"); 22 23=head1 DESCRIPTION 24 25(This module is modified from Gisle Aas File::CounterFile to use 26 Interchange's locking protocols -- lack of fcntl locking was causing 27 counter problems.) 28 29This module implements a persistent counter class. Each counter is 30represented by a separate file in the file system. File locking is 31applied, so multiple processes might try to access the same counters 32at the same time without risk of counter destruction. 33 34You give the file name as the first parameter to the object 35constructor (C<new>). The file is created if it does not exist. 36 37If the file name does not start with "/" or ".", then it is 38interpreted as a file relative to C<$Vend::CounterFile::DEFAULT_DIR>. 39The default value for this variable is initialized from the 40environment variable C<TMPDIR>, or F</usr/tmp> is no environment 41variable is defined. You may want to assign a different value to this 42variable before creating counters. 43 44If you pass a second parameter to the constructor, that sets the 45initial value for a new counter. This parameter only takes effect 46when the file is created (i.e. it does not exist before the call). 47 48When you call the C<inc()> method, you increment the counter value by 49one. When you call C<dec()> the counter value is decrementd. In both 50cases the new value is returned. The C<dec()> method only works for 51numerical counters (digits only). 52 53You can peek at the value of the counter (without incrementing it) by 54using the C<value()> method. 55 56The counter can be locked and unlocked with the C<lock()> and 57C<unlock()> methods. Incrementing and value retrieval is faster when 58the counter is locked, because we do not have to update the counter 59file all the time. You can query whether the counter is locked with 60the C<locked()> method. 61 62There is also an operator overloading interface to the 63Vend::CounterFile object. This means that you might use the C<++> 64operator for incrementing the counter, C<--> operator for decrementing 65and you can interpolate counters diretly into strings. 66 67=head1 BUGS 68 69(This problem alleviated by this modified module) 70 71It uses flock(2) to lock the counter file. This does not work on all 72systems. Perhaps we should use the File::Lock module? 73 74 75=head1 COPYRIGHT 76 77Copyright (c) 1995-1998 Gisle Aas. All rights reserved. 78Modifications made by and copyright (C) 2002 Red Hat, Inc. 79and (c) 2002-2007 Interchange Development Group 80 81This library is free software; you can redistribute it and/or 82modify it under the same terms as Perl itself. 83 84=head1 AUTHOR 85 86Gisle Aas <aas@sn.no> 87 88=cut 89 90require 5.005; 91use Carp qw(croak); 92use Symbol qw(gensym); 93my $rewind_check; 94eval { 95 require 5.005; 96 require Errno; 97 import Errno qw(EINTR); 98 $rewind_check = 1; 99}; 100 101sub Version { $VERSION; } 102$VERSION = sprintf("%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/); 103 104# first line in counter file, regex to match good value 105$MAGIC = "#COUNTER-1.0\n"; # first line in standard counter files 106# first line in date counter files 107$MAGIC_RE = qr/^#COUNTER-1.0-(gmt|date)-([A-Za-z0-9]+)/; 108$MAGIC_DATE = "#COUNTER-1.0-date"; # start of first line in date counter files 109$MAGIC_GMT = "#COUNTER-1.0-gmt"; # start of first line in gmt counter files 110 111$DEFAULT_INITIAL = 0; # default initial counter value 112$DEFAULT_DATE_INITIAL = '0000'; # default initial counter value in date mode 113$DATE_FORMAT = '%Y%m%d'; 114 115 # default location for counter files 116$DEFAULT_DIR ||= $ENV{TMPDIR} || "/usr/tmp"; 117 118# Experimental overloading. 119use overload ('++' => \&inc, 120 '--' => \&dec, 121 '""' => \&value, 122 fallback => 1, 123 ); 124 125 126sub new 127{ 128 my($class, $file, $initial, $date, $inc_routine, $dec_routine) = @_; 129 croak "No file specified\n" unless defined $file; 130 131 $file = "$DEFAULT_DIR/$file" unless $file =~ /^[\.\/]/; 132 $initial = $date ? $DEFAULT_DATE_INITIAL : $DEFAULT_INITIAL 133 unless defined $initial; 134 135 my $gmt; 136 my $magic_value; 137 138 local($/, $\) = ("\n", undef); 139 my ($fh, $first_line, $value) = get_initial_fh($file); 140 if (! $fh) { 141 if($first_line eq $MAGIC) { 142 # do nothing 143 } 144 elsif( $first_line =~ $MAGIC_RE) { 145 $date = $1; 146 $initial = $2; 147#::logDebug("read existing date counter, date=$date initial=$initial"); 148 $gmt = 1 if $date eq 'gmt'; 149 $magic_value = $first_line; 150 } 151 else { 152 chomp($first_line); 153 croak ::errmsg("Bad counter magic '%s' in %s", $first_line, $file); 154 } 155 chomp($value); 156 } else { 157 if($date) { 158 my $ivalue; 159 if($date eq 'gmt') { 160 $magic_value = $MAGIC_GMT . "-$initial\n"; 161 print $fh $magic_value; 162 $ivalue = strftime('%Y%m%d', gmtime()) . $initial; 163 print $fh "$ivalue\n"; 164 $gmt = 1; 165 } 166 else { 167 $magic_value = $MAGIC_DATE . "-$initial\n"; 168 print $fh $magic_value; 169 $ivalue = strftime('%Y%m%d', localtime()) . $initial; 170 print $fh "$ivalue\n"; 171 } 172 $value = $ivalue; 173 } 174 else { 175 print $fh $MAGIC; 176 print $fh "$initial\n"; 177 $value = $initial; 178 } 179 close($fh); 180 } 181 182 my $s = { file => $file, # the filename for the counter 183 'value' => $value, # the current value 184 updated => 0, # flag indicating if value has changed 185 inc_routine => $inc_routine, # Custom incrementor 186 dec_routine => $dec_routine, # Custom decrementor 187 initial => $initial, # initial value for date-based 188 magic_value => $magic_value, # initial magic value for date-based 189 date => $date, # flag indicating date-based counter 190 gmt => $gmt, # flag indicating GMT for date 191 # handle => XXX, # file handle symbol. Only present when locked 192 }; 193#::logDebug("counter object created: " . ::uneval($s)); 194 return bless $s; 195} 196 197sub get_initial_fh { 198 my $file = shift; 199 200 my $created; 201 my $fh = gensym(); 202 203 ( open $fh, "+<$file" or 204 (++$created and open $fh, ">>$file" and open $fh, "+<$file" ) 205 ) or croak "Can't open $file: $!"; 206 207 Vend::Util::lockfile($fh, 1, 1) 208 or croak "Can't lock $file: $!"; 209 210 seek $fh, 0, 0; 211 212 local($/) = "\n"; 213 my $magic = <$fh>; 214 my $value = <$fh>; 215 216 unless($created) { 217 close $fh; 218 undef $fh; 219 } 220 return ($fh, $magic, $value); 221} 222 223sub inc_value { 224 my $self = shift; 225 if ($self->{inc_routine}) { 226 $self->{value} = $self->{inc_routine}->($self->{value}); 227 return; 228 } 229 $self->{'value'}++, return unless $self->{date}; 230 my $datebase = $self->{gmt} 231 ? strftime($DATE_FORMAT, gmtime()) 232 : strftime($DATE_FORMAT, localtime()); 233 $self->{value} = $datebase . ($self->{initial} || $DEFAULT_DATE_INITIAL) 234 if $self->{value} lt $datebase; 235 my $inc = substr($self->{value}, 8); 236#::logDebug("initial=$self->{initial} inc before autoincrement value=$inc"); 237 $inc++; 238#::logDebug("initial=$self->{initial} inc after autoincrement value=$inc"); 239 $self->{value} = $datebase . $inc; 240} 241 242sub dec_value { 243 my $self = shift; 244 if ($self->{dec_routine}) { 245 $self->{value} = $self->{dec_routine}->($self->{value}); 246 return; 247 } 248 $self->{'value'}--; 249 return; 250} 251 252sub locked 253{ 254 exists shift->{handle}; 255} 256 257 258sub lock 259{ 260 my($self) = @_; 261 $self->unlock if $self->locked; 262 263 my $fh = gensym(); 264 my $file = $self->{file}; 265 266 open($fh, "+<$file") or croak "Can't open $file: $!"; 267 Vend::Util::lockfile($fh, 1, 1) 268 or croak "Can't flock: $!"; 269 270 local($/) = "\n"; 271 my $magic = <$fh>; 272 if ($magic ne $MAGIC and $magic !~ $MAGIC_RE ) { 273 $self->unlock; 274 chomp $magic; 275 croak errmsg("Bad counter magic '%s' in %s on lock", $magic, $file); 276 } 277 chomp($self->{'value'} = <$fh>); 278 279 $self->{handle} = $fh; 280 $self->{updated} = 0; 281 $self; 282} 283 284 285sub unlock 286{ 287 my($self) = @_; 288 return unless $self->locked; 289 290 my $fh = $self->{handle}; 291 292 if ($self->{updated}) { 293 # write back new value 294 local($\) = undef; 295 my $sstatus; 296 do { 297 $sstatus = seek($fh, 0, 0) 298 } while $rewind_check and ! $sstatus and $!{EINTR}; 299 300 croak "Can't seek to beginning: $!" 301 if ! $sstatus; 302 303 print $fh $self->{magic_value} || $MAGIC; 304 print $fh "$self->{'value'}\n"; 305 } 306 307 close($fh) or warn "Can't close: $!"; 308 delete $self->{handle}; 309 $self; 310} 311 312 313sub inc 314{ 315 my($self) = @_; 316 317 if ($self->locked) { 318 $self->inc_value(); 319 $self->{updated} = 1; 320 } else { 321 $self->lock; 322 $self->inc_value(); 323 $self->{updated} = 1; 324 $self->unlock; 325 } 326 $self->{'value'}; # return value 327} 328 329 330sub dec 331{ 332 my($self) = @_; 333 334 if ($self->locked) { 335 croak "Autodecrement is not magical in perl" 336 unless $self->{dec_routine} || $self->{'value'} =~ /^\d+$/; 337 croak "cannot decrement date-based counters" 338 if $self->{date}; 339 $self->dec_value(); 340 $self->{updated} = 1; 341 } else { 342 $self->lock; 343 croak "Autodecrement is not magical in perl" 344 unless $self->{dec_routine} || $self->{'value'} =~ /^\d+$/; 345 croak "cannot decrement date-based counters" 346 if $self->{date}; 347 $self->dec_value(); 348 $self->{updated} = 1; 349 $self->unlock; 350 } 351 $self->{'value'}; # return value 352} 353 354 355sub value 356{ 357 my($self) = @_; 358 my $value; 359 if ($self->locked) { 360 $value = $self->{'value'}; 361 } else { 362 $self->lock; 363 $value = $self->{'value'}; 364 $self->unlock; 365 } 366 $value; 367} 368 369 370sub DESTROY 371{ 372 my $self = shift; 373 $self->unlock; 374} 375 376#################################################################### 377# 378# S E L F T E S T S E C T I O N 379# 380##################################################################### 381# 382# If we're not use'd or require'd execute self-test. 383# 384# Test is kept behind __END__ so it doesn't take uptime 385# and memory unless explicitly required. If you're working 386# on the code you might find it easier to comment out the 387# eval and __END__ so that error line numbers make more sense. 388 389package main; 390 391eval join('',<DATA>) || die $@ unless caller(); 392 3931; 394 395__END__ 396 397 398$cf = "./zz-counter-$$"; # the name for out temprary counter 399 400# Test normal object creation and increment 401 402$c = new Vend::CounterFile $cf; 403 404$id1 = $c->inc; 405$id2 = $c->inc; 406 407$c = new Vend::CounterFile $cf; 408$id3 = $c->inc; 409$id4 = $c->dec; 410 411die "test failed" unless ($id1 == 1 && $id2 == 2 && $id3 == 3 && $id4 == 2); 412unlink $cf; 413 414# Test magic increment 415 416$id1 = (new Vend::CounterFile $cf, "aa98")->inc; 417$id2 = (new Vend::CounterFile $cf)->inc; 418$id3 = (new Vend::CounterFile $cf)->inc; 419 420eval { 421 # This should now work because "Decrement is not magical in perl" 422 $c = new Vend::CounterFile $cf; $id4 = $c->dec; $c = undef; 423}; 424die "test failed (No exception to catch)" unless $@; 425 426#print "$id1 $id2 $id3\n"; 427 428die "test failed" unless ($id1 eq "aa99" && $id2 eq "ab00" && $id3 eq "ab01"); 429unlink $cf; 430 431# Test operator overloading 432 433$c = new Vend::CounterFile $cf, "100"; 434 435$c->lock; 436 437$c++; # counter is now 101 438$c++; # counter is now 102 439$c++; # counter is now 103 440$c--; # counter is now 102 again 441 442$id1 = "$c"; 443$id2 = ++$c; 444 445$c = undef; # destroy object 446 447unlink $cf; 448 449die "test failed" unless $id1 == 102 && $id2 == 103; 450 451 452print "Selftest for Vend::CounterFile $Vend::CounterFile::VERSION ok\n"; 453