File Coverage

blib/lib/Tie/DB_Lock.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Tie::DB_Lock;

use strict;
use Carp;
use Fcntl(':flock');
use DB_File;
use FileHandle;

use vars qw($VERSION $WAIT_TIME $RETRIES $TEMPDIR $VERBOSE $TIEPACK);
$VERSION = '0.07';

$TEMPDIR   = '/tmp'    unless defined $TEMPDIR;
$TIEPACK   = 'DB_File' unless defined $TIEPACK;
$WAIT_TIME = 1         unless defined $WAIT_TIME;
$RETRIES   = 15        unless defined $RETRIES;
$VERBOSE   = 0         unless defined $VERBOSE;  # Print out diagnostics on STDERR?

# For internal use only:
my $READ_WRITE = O_CREAT|O_RDWR;
my $READ_ONLY = O_RDONLY;

# Values acceptable to lock_file:
my %LOCKS = (
	     "ex" => LOCK_EX|LOCK_NB,   # Exclusive
	     "sh" => LOCK_SH|LOCK_NB,   # Shared
	     "un" => LOCK_UN|LOCK_NB,   # Unlock
	    );

sub jabber ($) { carp("$$: $_[0]") if $VERBOSE }

sub TIEHASH {
  my $class = shift;
  my $filename = shift;
  my $mode = shift() . '';
  my $self = {'db' => {},
	      'fh' => undef,
	      'mode' => $mode,
	     };

  if ($mode eq 'rw') {
    # Open a hashfile and put an exclusive lock on it.

    jabber "Attempting to gain read/write access to $filename";

    if (not -e $filename) {
      jabber "$filename doesn't exist, creating it";
      # Create it in the proper format.  This is necessary for locking:
      unless (defined ($self->{'db'} = $TIEPACK->TIEHASH($filename, $READ_WRITE, 0660)) ) {
	jabber "Couldn't create $filename: $!";
	return;
      }
      delete $self->{'db'};
    }

    # Try to lock the file:
    if ($self->{'fh'} = new FileHandle($filename,$READ_WRITE)) {
      jabber "Opened $filename";
    } else {
      jabber "Couldn't open $filename for locking: $!";
      return;
    }
    unless (lock_file($self->{'fh'}, 'ex')) {
      jabber "Couldn't lock $filename";
      close $self->{'fh'};
      return;
    }

    # Tie a hash to the file:
    $self->{'db'} = $TIEPACK->TIEHASH($filename, $READ_WRITE, 0660);

  } else {
    jabber "Attempting to gain read-only access to $filename";


    my $tempfile = "$TEMPDIR/" . _random_string();

    # Try to lock the file:
    my $temp_fh = new FileHandle($filename);
    unless (defined $temp_fh) {
      jabber "Couldn't open $filename for reading: $!";
      return;
    }
    unless (lock_file($temp_fh, 'sh')) {
      jabber "Couldn't lock $filename, aborting dbm_open_ro";
      close $temp_fh;
      return;
    }

    # Copy to a tempfile:

    unless (system ("cp $filename $tempfile") == 0) {
      jabber "cp of $filename to $tempfile failed: $!";
      return;
    }
    jabber "Copied $filename to $tempfile";


    # Unlock & close:
    unless ( lock_file($temp_fh, 'un')) {
      jabber "Couldn't unlock $filename: $!";
      close $temp_fh;
      unless (unlink $tempfile) {
	jabber "IMPORTANT! Couldn't unlink tempfile $tempfile: $!";
      }
      return;
    }
    close $temp_fh;


    # Tie the tempfile:
    $self->{'db'} = $TIEPACK->TIEHASH($tempfile, $READ_ONLY, 0660);
    $self->{tempfile} = $tempfile;

    # Delete the tempfile (don't worry, it will appear to remain
    # around until you close it, at least on UNIX):
    unless (unlink $tempfile) {
      warn("Couldn't remove tempfile $tempfile: $!");
      return;
    }
  }

  unless ($self->{'db'}) {
    carp "$TIEPACK->TIEHASH failed: $!";
    return;
  }

  return bless $self, $class;
}

sub tempfile { $_[0]->{tempfile} }

sub DESTROY {
  # Called to close, unlock, and untie a hashfile:

  my $self = shift;

  jabber "Database closing process begun";

  delete $self->{'db'};

  if ($self->{'mode'} eq 'rw') {
    jabber "Closing read/write file";

    # Close the file - this removes the lock too
    close $self->{'fh'} or croak "Couldn't unlock & close database: $!";
  }

  jabber "dbm_close completed";

  return 1;
}

#line 161
sub FETCH      { my $self=shift; $self->{'db'}->FETCH(@_) }
sub STORE      { my $self=shift; $self->{'db'}->STORE(@_) }
sub DELETE     { my $self=shift; $self->{'db'}->DELETE(@_) }
sub FIRSTKEY   { my $self=shift; $self->{'db'}->FIRSTKEY(@_) }
sub NEXTKEY    { my $self=shift; $self->{'db'}->NEXTKEY(@_) }
sub EXISTS     { my $self=shift; $self->{'db'}->EXISTS(@_) }
sub CLEAR      { my $self=shift; $self->{'db'}->CLEAR(@_) }


sub _random_string {
  # Usage: $filehandle = _random_string($n_chars);
  #
  # Returns a string made of $n_chars (default 9) random letters.

  my $chars = @_ ? shift() : 9;
  my $string_chars = "QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm";

  my $string_out = '';
  my $i;
  for($i=0; $i<$chars; $i++) {
    $string_out .= substr($string_chars, int(rand length $string_chars), 1);
  }
  return $string_out;
}

sub lock_file($$) {
  # Usage: lock_file FILEHANDLE, lock_type;
  #        where FILEHANDLE is an _open_ filehandle,
  #        and lock_type is "ex" or "sh" for exclusive or shared locks.

  my $filehandle = shift;
  my $type       = shift;
  my ($i, $didlock) = (0,0);

  unless (exists $LOCKS{$type}) { croak("Invalid lock type: '$type'"); }

  # Try to apply the lock:
  while (1) {
    if (flock ($filehandle, $LOCKS{$type})) {
      jabber "Lock successfully obtained";
      $didlock = 1;
      last;
    } else {
      jabber "Lock attempt $i failed: $!";
    }

    last if ++$i > $RETRIES;
    jabber "Sleeping for $WAIT_TIME seconds";
    sleep $WAIT_TIME;
  }

  unless ($didlock) {
    jabber "Lock ($type) attempt $i (final) failed ($!), aborting";
    return 0;
  }

  return 1;
}

1;
__END__