Tie::DB_Lock - ties hashes to databases using shared and exclusive locks

 use Tie::DB_Lock;
 use DB_File;

 tie(%hash, 'Tie::DB_Lock', $filename, 'rw');  # Open for writing
 $hash{'key'} = 'value';
 untie %hash;

 tie(%hash2, 'Tie::DB_Lock', $filename); # Default is read-only
 print("Value is $hash2{'key'}\n");
 untie %hash;

  tie(%hash, 'Tie::DB_Lock', $file, 'rw') or die $!;

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__