/usr/local/CPAN/Tie-DB_File-SplitHash/Tie/DB_File/SplitHash.pm

• package Tie::DB_File::SplitHash
  • TIEHASH
  • STORE
  • FETCH
  • DELETE
  • CLEAR
  • EXISTS
  • DESTROY
  • FIRSTKEY
  • NEXTKEY
  • _section_hash
  • put
  • get
  • seq
  • del
  • sync
  • fd
  • exists
  • clear
• EOF

package Tie::DB_File::SplitHash;

use strict;

use DB_File;
use File::Path;
use File::Spec;
use Digest::SHA1 qw (sha1_hex);
use Fcntl qw (:flock);

require Exporter;
use vars qw ($VERSION @ISA @EXPORT $DB_HASH);

$VERSION = '1.05';
@ISA     = qw (Tie::Hash Exporter);
@EXPORT  = qw(
		$DB_HASH 
		DB_LOCK     DB_SHMEM        DB_TXN          HASHMAGIC
		HASHVERSION MAX_PAGE_NUMBER MAX_PAGE_OFFSET MAX_REC_NUMBER
		RET_ERROR   RET_SPECIAL     RET_SUCCESS     R_CURSOR
		R_DUP       R_FIRST         R_FIXEDLEN      R_IAFTER
		R_IBEFORE   R_LAST          R_NEXT          R_NOKEY
		R_NOOVERWRITE R_PREV        R_RECNOSYNC     R_SETCURSOR
		R_SNAPSHOT  __R_UNUSED); 
eval {
	# Make all Fcntl O_XXX constants available for importing
	require Fcntl;
	my @O = grep /^O_/, @Fcntl::EXPORT;
	Fcntl->import(@O);  # first we import what we want to export
	push(@EXPORT, @O);
};

###############################################################################

sub TIEHASH {
	my $class = shift;
    my $package = __PACKAGE__;
	my $self  = bless {},$class;
	my $parms = [@_];
	my $vars = {};
	$self->{$package} = $vars;

	$vars->{'-init_parms'} = $parms;
	my $n_parms = $#$parms + 1;
	if ($n_parms != 5) {
		require Carp;
		Carp::croak($package . "::init_hash() - incorrect number of calling parameters\n");
	}
	my $multi_n = pop @$parms;
	$vars->{'-multi_n'} = $multi_n;
	$vars->{'-dirname'} = $parms->[0];
	if (not ((-e $vars->{'-dirname'}) or (mkdir ($vars->{'-dirname'},0777)))) {
		require Carp;
		Carp::croak($package . '::TIEHASH - datafiles directory ' . $vars->{'-dirname'} . " does not exist and cannot be created.\n$!");
	}
	my $main_index_file  = File::Spec->catfile($vars->{'-dirname'}, 'index');
	shift @$parms;
	$multi_n--;
	my $errors=0;
	my $error_message = '';
	foreach my $f_part (0..$multi_n) {
		my $tied_hash = {};
		my $db_object = tie %$tied_hash,'DB_File',"${main_index_file}_${f_part}.db",@$parms;
		if (not defined $db_object) {
			$errors = $f_part + 1;
			$error_message = $!;
			last;
		}
		$vars->{'db'}->[$f_part]->{-object} = $db_object;
	}
	if ($errors) {
		delete $vars->{'db'};
		require Carp;
		Carp::croak ("Failed to open database: $error_message\n");
	}

	return $self;
}

#######################################################################

sub STORE {
	my $self = shift;
	my $package = __PACKAGE__;

	my ($key,$value) = @_;
	my $section = $self->_section_hash($key);
	my $db_object = $self->{$package}->{'db'}->[$section]->{'-object'};
	return $db_object->STORE(@_);
}

#######################################################################

sub FETCH {
	my $self = shift;
	my $package = __PACKAGE__;

	my ($key)  = @_;

	my $section   = $self->_section_hash($key);
	my $db_object = $self->{$package}->{'db'}->[$section]->{-object};
	return $db_object->FETCH(@_);
}

#######################################################################

sub DELETE {
	my $self = shift;
	my $package = __PACKAGE__;
	
	my ($key) = @_;

	my $section   = $self->_section_hash($key);
	my $db_object = $self->{$package}->{'db'}->[$section]->{'-object'};
	return $db_object->DELETE(@_);
}

#######################################################################

sub CLEAR {
	my $self = shift;
	my $package = __PACKAGE__;

    my $list_of_dbs = $self->{$package}->{'db'};
    my $counter = 0;
	foreach my $database (@$list_of_dbs) {
		my $db_object = $database->{'-object'};
        $counter++;
		$db_object->CLEAR(@_);
	}
}

#######################################################################

sub EXISTS {
	my $self = shift;
	my $package = __PACKAGE__;
	
	my ($key) = @_;

	my $section   = $self->_section_hash($key);
	my $db_object = $self->{$package}->{'db'}->[$section]->{'-object'};
	return $db_object->EXISTS(@_);
}

#######################################################################

sub DESTROY {
	my $self = shift;
	my $package = __PACKAGE__;

	delete $self->{$package}->{'db'};
}

#######################################################################

sub FIRSTKEY {
	my $self = shift;
	my $package = __PACKAGE__;
	my $vars = $self->{$package};
	my $db_object = $vars->{'db'}->[0]->{'-object'};
	$vars->{-iteration_section} = 0;
	return $db_object->FIRSTKEY(@_);
}

#######################################################################

sub NEXTKEY {
	my $self = shift;
	my $package = __PACKAGE__;
	my $vars = $self->{$package};
	
	my ($key) = @_;

	my $section   = $vars->{'-iteration_section'};
	my $multi_n   = $vars->{'-multi_n'};
	my $db_object = $vars->{'db'}->[$section]->{'-object'};
	my $next_key;
	while (not defined $next_key) {
		$next_key = $db_object->NEXTKEY($key);
		if (not defined $next_key) {
			$section++;
			$vars->{-iteration_section} = $section;
            my $next_section = $vars->{'db'}->[$section];
            last unless (defined $next_section);
			$db_object = $next_section->{'-object'};
			$next_key = $db_object->FIRSTKEY;
		}
	}
	return $next_key;
}

#######################################################################

sub _section_hash {
	my $self = shift;
	my $package = __PACKAGE__;
	
	my ($key) = @_;

    $key = '' unless defined $key;
	my $sections    = $self->{$package}->{'-multi_n'};
	my $digest      = sha1_hex($key);
	my $section_n   = hex(substr($digest,0,2)) % $sections;
	return $section_n;
}

#######################################################################

sub put {
	my $self = shift;
	my $package = __PACKAGE__;

	my $parms = [];
	@$parms   = @_;
	my $key   = shift @$parms;
	my $section = $self->_section_hash($key);
	my $db_object = $self->{$package}->{'db'}->[$section]->{'-object'};
	return $db_object->put(@_);
}

#######################################################################

sub get {
	my $self = shift;
	my $package = __PACKAGE__;

	my $parms     = [@_];
	my $key       = shift @$parms;
	my $section   = $self->_section_hash($key);
	my $db_object = $self->{$package}->{'db'}->[$section]->{'-object'};
    return $db_object->get(@_);
}

#######################################################################

sub seq {
	my $self = shift;
	my $package = __PACKAGE__;

	my $parms     = [@_];
	my $key       = shift @$parms;
	my $section   = $self->_section_hash($key);
	my $db_object = $self->{$package}->{'db'}->[$section]->{'-object'};
	return $db_object->seq(@_);
}

#######################################################################

sub del {
	my $self = shift;
	my $package = __PACKAGE__;

	my $parms     = [@_];
	my $key       = shift @$parms;
	my $section   = $self->_section_hash($key);
	my $db_object = $self->{$package}->{'db'}->[$section]->{'-object'};
	return $db_object->del(@_);
}

#######################################################################

sub sync {
	my $self = shift;
	my $package = __PACKAGE__;

	foreach my $db (@{$self->{$package}->{'db'}}) {
		$db->{'-object'}->sync(@_);
	}
}

#######################################################################

sub fd {
	my $self = shift;
	my $package = __PACKAGE__;
	return $self->{$package}->{'db'}->[0]->{'-object'}->fd(@_);
}

#######################################################################

sub exists {
	return shift->EXISTS(@_);
}

#######################################################################

sub clear {
	return shift->CLEAR(@_);
}

#######################################################################

1;