=head1 CLASS
Title: POP::Id_factory.pm
Desc: Abstract class for all id factories. Derived classes should call
constructor with an argument for the file. Derived class may
(and should) use $ENV{'FACTORY_HOME'}, which is set to a default value
here.
Author: B. Holzman
=cut
$VERSION = do{my(@r)=q$Revision: 1.2 $=~/\d+/g;sprintf '%d.'.'%02d'x$#r,@r};
# Get, or set to default, the directory holding the ID file.
BEGIN {
$ENV{'FACTORY_HOME'} ||= '.';
}
use strict;
use Carp;
use Symbol;
use POSIX qw/EBADF EDEADLK/;
use vars qw/$VERSION/;
# PUBLIC METHODS
=head2 CONSTRUCTOR
Title: Id_Factory::new
Desc: Constructor
Error: YES
=cut
sub new {
my($type, $file) = @_;
my $no;
my $this = {'file' => $file};
# Open the ID file.
my $sym = gensym;
unless (open($sym, "+<$file")) {
croak "Couldn't open [$file]: $!";
}
my $old = new SelectSaver $sym;
$| = 1;
$this->{'fh'} = $sym;
return bless $this, $type;
}
=head2 DESTRUCTOR
Title: Id_factory::DESTROY
Desc: Destructor
Error: NO
=cut
sub DESTROY { }
=head2 METHOD
Title: Id_factory::next
Desc: Locks factory file, reads in current id, increments, writes it back
out, and unlocks.
Error: YES
=cut
sub next {
my $this = shift;
my $fh = $this->{'fh'};
# First, seek to the beginning:
seek($fh,0,0);
$this->_lock;
# Read in current ID
my $old_id;
chomp($old_id = <$fh>);
# Increment ID
my $new_id = $this->_id_increment($old_id);
unless ($new_id) {
croak "Couldn't increment [$old_id]";
}
# Write ID out
seek($fh,0,0);
print $fh "$new_id\n";
truncate($fh,length($new_id)+1);
$this->_unlock;
return $new_id;
}
=head2 METHOD
Title: Id_factory::set
Desc: Sets the current value in the ID file to the given arg.
Primarily a maintenance tool.
Error: YES
=cut
sub set {
my($this, $value) = @_;
my $fh = $this->{'fh'};
unless (defined($value)) {
croak "No value supplied";
}
seek($fh,0,0);
$this->_lock;
print $fh "$value\n";
truncate($fh,length($value) + 1);
$this->_unlock;
}
# PRIVATE METHODS
=head2 METHOD
Title: Id_factory::_lock
Desc: Carefully locks filehandle; will use $this->{'fh'} by default, or Arg1.
For message logging, uses $this->{'file'} as filename, or Arg2.
Error: YES
=cut
sub _lock {
my $this = shift;
my $fh = shift || $this->{'fh'};
my $file = shift || $this->{'file'};
my $retries = 3;
my $status = undef;
my $no;
do {
$status = File::lockf::lock($fh);
if ($status == EBADF) {
croak "Bad filehandle error locking [$file]";
} elsif ($status == EDEADLK) {
unless (--$retries) {
croak "Deadlock error locking [$file]";
}
# let's take a nap and try again...
sleep 2;
} elsif ($status) { # This should be ECOMM, but it's not in POSIX
unless (--$retries) {
croak "Communication error (NFS?) locking [$file]";
}
# let's give NFS a little time...
sleep 10;
} else {
$retries = 0;
}
} while ($retries);
}
=head2 METHOD
Title: Id_factory::_unlock
Desc: Unlocks filehandle. Filehandle is $this->{'fh'} or Arg1.
Filename is $this->{'file'} or Arg2.
Error: NO
=cut
sub _unlock {
my $this = shift;
my $fh = shift || $this->{'fh'};
my $file = shift || $this->{'file'};
my $status = undef;
seek($fh,0,0);
$status = File::lockf::ulock($fh);
if ($status == EBADF) {
croak "Bad filehandle error unlocking [$file]";
} elsif ($status == EDEADLK) {
croak "Lock table full error unlocking [$file]";
} elsif ($status) { # Should be ECOMM, not defined in POSIX
# XXX This ain't portable, no doubt.
croak "Communication error (NFS?) unlocking [$file]";
}
}
=head2 METHOD
Title: Id_factory::_id_increment
Desc: Default ID incrementing method. (numeric)
Error: NO
=cut
sub _id_increment {
my($this,$old_id) = @_;
if (!defined($old_id) or $old_id < 0) {
return;
}
return $old_id + 1;
}
$VERSION=$VERSION;