File Coverage

blib/lib/DB_File/Lock.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

#
# DB_File::Lock
#
# by David Harris
#
# Copyright (c) 1999-2000 David R. Harris. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#

package DB_File::Lock;

require 5.004;

use strict;
use vars qw($VERSION @ISA $locks);

@ISA = qw(DB_File);
$VERSION = '0.05';

use DB_File ();
use Fcntl qw(:flock O_RDWR O_RDONLY O_WRONLY O_CREAT);
use Carp qw(croak carp);
use Symbol ();

# import function can't be inherited, so this magic required
sub import
{
	my $ourname = shift;
	my @imports = @_; # dynamic scoped var, still in scope after package call in eval
	my $module = caller;
	my $calling = $ISA[0];
	eval " package $module; import $calling, \@imports; ";
}

sub _lock_and_tie
{
	my $package = shift;

	## Grab the type of tie

	my $tie_type = pop @_;

	## There are two ways of passing data defined by DB_File

	my $lock_data;
	my @dbfile_data;

	if ( @_ == 5 ) {
		$lock_data = pop @_;
		@dbfile_data = @_;
	} elsif ( @_ == 2 ) {
		$lock_data = pop @_;
		@dbfile_data = @{$_[0]};
	} else {
		croak "invalid number of arguments";
	}

	## Decipher the lock_data

	my $mode;
	my $nonblocking   = 0;
	my $lockfile_name = $dbfile_data[0] . ".lock";
	my $lockfile_mode;

	if ( lc($lock_data) eq "read" ) {
		$mode = "read";
	} elsif ( lc($lock_data) eq "write" ) {
		$mode = "write";
	} elsif ( ref($lock_data) eq "HASH" ) {
		$mode = lc $lock_data->{mode};
		croak "invalid mode ($mode)" if ( $mode ne "read" and $mode ne "write" );
		$nonblocking = $lock_data->{nonblocking};
		$lockfile_name = $lock_data->{lockfile_name} if ( defined $lock_data->{lockfile_name} );
		$lockfile_mode = $lock_data->{lockfile_mode};
	} else {
		croak "invalid lock_data ($lock_data)";
	}

	## Warn about opening a lockfile for writing when only locking for reading

	# NOTE: This warning disabled for RECNO because RECNO seems to require O_RDWR
	# even when opening only for reading.

	carp "opening with write access when locking only for reading (use O_RDONLY to fix)"
		if (
			( $dbfile_data[1] && O_RDWR or $dbfile_data[1] && O_WRONLY ) # any kind of write access
			and $mode eq "read"                                          # and opening for reading
			and $tie_type ne "TIEARRAY"                                  # and not RECNO
		);

	## Determine the mode of the lockfile, if not given

	# THEORY: if someone can read or write the database file, we must allow
	# them to read and write the lockfile.

	if ( not defined $lockfile_mode ) {
		$lockfile_mode = 0600; # we must be allowed to read/write lockfile
		$lockfile_mode |= 0060 if ( $dbfile_data[2] & 0060 );
		$lockfile_mode |= 0006 if ( $dbfile_data[2] & 0006 );
	 }

	## Open the lockfile, lock it, and open the database

	my $lockfile_fh = Symbol::gensym();
	my $saved_umask = umask(0000) if ( umask() & $lockfile_mode );
	my $open_ok = sysopen($lockfile_fh, $lockfile_name, O_RDWR|O_CREAT,
            $lockfile_mode);
	umask($saved_umask) if ( defined $saved_umask );
	$open_ok or croak "could not open lockfile ($lockfile_name)";

	my $flock_flags = ($mode eq "write" ? LOCK_EX : LOCK_SH) | ($nonblocking ? LOCK_NB : 0);
	if ( not flock $lockfile_fh, $flock_flags ) {
		close $lockfile_fh;
		return undef if ( $nonblocking );
		croak "could not flock lockfile";
	}

	my $self = $tie_type eq "TIEHASH"
		? $package->SUPER::TIEHASH(@_)
		: $package->SUPER::TIEARRAY(@_);
	if ( not $self ) {
		close $lockfile_fh;
		return $self;
	}

	## Store the info for the DESTROY function

	my $id = "" . $self;
	$id =~ s/^[^=]+=//; # remove the package name in case re-blessing occurs
	$locks->{$id} = $lockfile_fh;

	## Return the object

	return $self;
}

sub TIEHASH
{
	return _lock_and_tie(@_, 'TIEHASH');
}

sub TIEARRAY
{
	return _lock_and_tie(@_, 'TIEARRAY');
}

sub DESTROY
{
	my $self = shift;

	my $id = "" . $self;
	$id =~ s/^[^=]+=//;
	my $lockfile_fh = $locks->{$id};
	delete $locks->{$id};

	$self->SUPER::DESTROY(@_);

	# un-flock not needed, as we close here
	close $lockfile_fh;
}





1;
__END__