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