home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _6fba5a7eaee3d884f29e6905b578f457 < prev    next >
Text File  |  2004-06-01  |  6KB  |  262 lines
  1. package File::CounterFile;
  2.  
  3. # $Id: CounterFile.pm,v 0.23 2004/01/23 08:37:18 gisle Exp $
  4.  
  5. require 5.004;
  6.  
  7. use strict;
  8.  
  9. use Carp   qw(croak);
  10. use Symbol qw(gensym);
  11. use Fcntl qw(LOCK_EX O_RDWR O_CREAT);
  12.  
  13. BEGIN {
  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.  
  23. use vars qw($VERSION $MAGIC $DEFAULT_INITIAL $DEFAULT_DIR);
  24.  
  25. sub 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} || "/usr/tmp";
  33.  
  34. # Experimental overloading.
  35. use overload ('++'     => \&inc,
  36.           '--'     => \&dec,
  37.           '""'     => \&value,
  38.           fallback => 1,
  39.              );
  40.  
  41.  
  42. sub 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.  
  77. sub locked
  78. {
  79.     exists shift->{handle};
  80. }
  81.  
  82.  
  83. sub 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.  
  108. sub 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.  
  129. sub 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.  
  146. sub 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.  
  172. sub 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.  
  188. sub DESTROY
  189. {
  190.     my $self = shift;
  191.     $self->unlock;
  192. }
  193.  
  194. 1;
  195.  
  196. __END__
  197.  
  198. =head1 NAME
  199.  
  200. File::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.  
  212. This module implements a persistent counter class.  Each counter is
  213. represented by a separate file in the file system.  File locking is
  214. applied, so multiple processes can attempt to access a counter
  215. simultaneously without risk of counter destruction.
  216.  
  217. You give the file name as the first parameter to the object
  218. constructor (C<new>).  The file is created if it does not exist.
  219.  
  220. If the file name does not start with "/" or ".", then it is
  221. interpreted as a file relative to C<$File::CounterFile::DEFAULT_DIR>.
  222. The default value for this variable is initialized from the
  223. environment variable C<TMPDIR>, or F</usr/tmp> if no environment
  224. variable is defined.  You may want to assign a different value to this
  225. variable before creating counters.
  226.  
  227. If you pass a second parameter to the constructor, it sets the
  228. initial value for a new counter.  This parameter only takes effect
  229. when the file is created (i.e. it does not exist before the call).
  230.  
  231. When you call the C<inc()> method, you increment the counter value by
  232. one. When you call C<dec()>, the counter value is decremented.  In both
  233. cases the new value is returned.  The C<dec()> method only works for
  234. numerical counters (digits only).
  235.  
  236. You can peek at the value of the counter (without incrementing it) by
  237. using the C<value()> method.
  238.  
  239. The counter can be locked and unlocked with the C<lock()> and
  240. C<unlock()> methods.  Incrementing and value retrieval are faster when
  241. the counter is locked, because we do not have to update the counter
  242. file all the time.  You can query whether the counter is locked with
  243. the C<locked()> method.
  244.  
  245. There is also an operator overloading interface to the
  246. File::CounterFile object.  This means that you can use the C<++>
  247. operator for incrementing and the C<--> operator for decrementing the counter,
  248. and you can interpolate counters directly into strings.
  249.  
  250. =head1 COPYRIGHT
  251.  
  252. Copyright (c) 1995-1998,2002,2003 Gisle Aas. All rights reserved.
  253.  
  254. This library is free software; you can redistribute it and/or
  255. modify it under the same terms as Perl itself.
  256.  
  257. =head1 AUTHOR
  258.  
  259. Gisle Aas <gisle@aas.no>
  260.  
  261. =cut
  262.