File Coverage

blib/lib/File/CounterFile.pm

Criterion	Covered	Total	%
statement	97	103	94.1
branch	30	44	68.1
condition			n/a
subroutine	15	16	93.7
pod	0	8	0.0
total	142	171	83.0

package 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__