File Coverage

blib/lib/Search/InvertedIndex/Simple/BerkeleyDB.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 Search::InvertedIndex::Simple::BerkeleyDB;

# Name:
#	Search::InvertedIndex::Simple::BerkeleyDB.
#
# Documentation:
#	POD-style documentation is at the end. Extract it with pod2html.*.
#
# Reference:
#	Object Oriented Perl
#	Damian Conway
#	Manning
#	1-884777-79-1
#	P 114
#
# Note:
#	o Tab = 4 spaces || die.
#
# Author:
#	Ron Savage
#	Home page: http://savage.net.au/index.html
#
# Licence:
#	Australian copyright (c) 1999-2002 Ron Savage.
#
#	All Programs of mine are 'OSI Certified Open Source Software';
#	you can redistribute them and/or modify them under the terms of
#	The Artistic License, a copy of which is available at:
#	http://www.opensource.org/licenses/index.html

use strict;
use warnings;
no warnings 'redefine';

require 5.005_62;

use BerkeleyDB;
use Search::InvertedIndex::Simple;
use Set::Array;

our @ISA = qw(Search::InvertedIndex::Simple);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Search::InvertedIndex::Simple::BerkeleyDB ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);
our $VERSION = '1.06';

# -----------------------------------------------

# Encapsulated class data.

{
	my(%_attr_data) =
	(	# Alphabetical order.
		_dataset    => [],
		_keyset     => [],
		_lower_case => 0,
		_separator  => ',',
	);

	sub _default_for
	{
		my($self, $attr_name) = @_;

		$_attr_data{$attr_name};
	}

	sub _standard_keys
	{
		sort keys %_attr_data;
	}

}	# End of Encapsulated class data.

# -----------------------------------------------

sub db_get
{
	my($self, $key) = @_;

	my(%value);

	for (sort keys %$key)
	{
		Carp::croak("Unknown key: $_") if (! $$self{'_key'}{$_});

		$$self{'_dbh'}{$_} -> db_get($$key{$_}, $value{$_});
	}

	return \%value;

}	# End of db_get.

# -----------------------------------------------

sub db_print
{
	my($self) = @_;

	my($key, @log);

	for $key (sort keys %{$$self{'_dbh'} })
	{
		my($count)  = 0;
		my($cursor) = $$self{'_dbh'}{$key} -> db_cursor();
		my($k, $v)  = ('', '');

		push @log, $key;

		while ($cursor -> c_get($k, $v, DB_NEXT) == 0)
		{
			$count++;

			push @log, "$count: $k => $v";
		}
	}

	return \@log;

}	# End of db_print.

# -----------------------------------------------

sub db_put
{
	my($self) = @_;
	my($env)  = BerkeleyDB::Env -> new
	(
		Flags => DB_PRIVATE, # Use RAM rather than disk files for the database.
	);

	for (@{$$self{'_keyset'} })
	{
		$$self{'_dbh'}{$_} = BerkeleyDB::Btree -> new
		(
			Env => $env,
		) || Carp::croak("Can't create BerkeleyDB::Btree for index $_: $!");
	}

	my($index) = $self -> build_index();

	my($primary_key, $secondary_key, $key);

	for $primary_key (sort keys %$index)
	{
		for $secondary_key (sort keys %{$$index{$primary_key} })
		{
			$key = $$self{'_lower_case'} == 0 ? $secondary_key : lc $secondary_key;

			$$self{'_dbh'}{$primary_key} -> db_put($key, join(',', $$index{$primary_key}{$secondary_key} -> print() ) );
		}
	}

}	# End of db_put.

# -----------------------------------------------

sub inflate
{
	my($self, $value) = @_;

	my($set);

	for (sort keys %$value)
	{
		if (! $$value{$_})
		{
			$set = undef;

			last;
		}

		if (! $set)
		{
			$set = Set::Array -> new(split(/$$self{'_separator'}/, $$value{$_}) );
		}
		else
		{
			$set = Set::Array -> new(join(',', $set -> intersection(Set::Array -> new(split(/$$self{'_separator'}/, $$value{$_}) ) ) ) );
		}
	}

	return $set;

}	# End of inflate.

# -----------------------------------------------

sub new
{
	my($class, %arg) = @_;
	my($self)        = bless({}, $class);

	for my $attr_name ($self -> _standard_keys() )
	{
		my($arg_name) = $attr_name =~ /^_(.*)/;

		if (exists($arg{$arg_name}) )
		{
			$$self{$attr_name} = $arg{$arg_name};
		}
		else
		{
			$$self{$attr_name} = $self -> _default_for($attr_name);
		}
	}

	# There will be 1 database handle per entry in @{$$self{'_keyset'} }.
	# Also, convert keyset into a hash for ease of testing existances.

	$$self{'_dbh'}                             = {};
	@{$$self{'_key'} }{@{$$self{'_keyset'} } } = (1) x @{$$self{'_keyset'} };

	return $self;

}	# End of new.

# -----------------------------------------------

1;

__END__