view release on metacpan or  search on metacpan

Lite.pm  view on Meta::CPAN

sub duplicatekeys {
	return property => DB_DUP ;
	}

sub uniquepairs {
	return 	property => DB_DUP | DB_DUPSORT ;
	}

sub incrementkeys {
	return compare => sub { ( $_[0] || 0 ) <=> ( $_[1] || 0 ) } ;
	}

sub envsetup {
	my %config = ( @defaults, @_ ) ;
	croak "'home' not defined" unless $config{home} ;
	croak "'filename' not defined" unless $config{filename} ;

	### Environment ###
	my %args_env = () ;
	$args_env{'-Cachesize'} = $config{cachesize}
			if exists $config{cachesize} ;
	if ( exists $config{server} ) {
		$args_env{'-Server'} = $config{server} ;
		$args_env{'-Home'} = $config{home} ;
		}
	else {
		$args_env{'-Home'} = "$config{rootdir}/$config{home}" ;
		}

	my $flags = DB_CREATE | DB_INIT_MPOOL | DB_INIT_CDB ;
	$flags ||= DB_RECOVER if $config{recover} ;

	$env{ $config{home} } ||= new BerkeleyDB::Env
			%args_env,
			-Flags => $flags,
			or warn "$!" ;

	### Database ###
	my %args_db = () ;
	$args_db{filename} = "$config{rootdir}/$config{home}/$config{filename}"
			unless $config{server} ;
	$args_db{'-Env'} = $env{ $config{home} } ;
	$args_db{'-Filename'} = $config{filename} ;
	$args_db{'-Property'} = $config{property} if exists $config{property} ;
	$args_db{'-Compare'} = $config{compare} if exists $config{compare} ;

	return %args_db ;
	}

## intended for duplicatekeys
sub recordset {
	my $ref = shift ;
	my $self = tied %$ref ;
	my $key = shift ;
	my $value = "" ;

	my @values = () ;

	# database locked
	my $cursor = $self->db_cursor ;

	if ( $cursor->c_get( $key, $value, DB_SET ) ) {
		$cursor = undef ;
		return @values ;
		}

	push @values, $value ;
	while ( ! $cursor->c_get( $key, $value, DB_NEXT_DUP ) ) {
		push @values, $value ;
		}

	$cursor = undef ;
	return @values ;
	}

## experimental to improve durability
sub sync {
	my $ref = shift ;
	my $self = tied %$ref ;
	$self->db_sync ;
	}

sub syncall {
	map { $_->db_sync } values %dbreg ;
	}

## intended for duplicatekeys
sub delete {
	my $ref = shift ;
	my $self = tied %$ref ;
	my $key = shift ;
	my $value = shift ;
	my $orig = $value ;

	my $cursor = $self->db_cursor( DB_WRITECURSOR ) ;
	my $status = $cursor->c_get( $key, $value, DB_GET_BOTH ) ;

	## Warning: Ensure consistency between numbers with strings.
	## See Storable documentation.
	$cursor->c_del unless $status ;
	$cursor = undef ;

	return $status ;
	}

sub DESTROY {
	my $ref = shift ;
	my $self = tied %$ref ;
	return unless $self ;

	delete $dbreg{ $self->[0] } ;

	## Sleepycat suggests that as an RPC client, db_close is a noop.
	## In that case, db_sync ought to be called instead.
	## How to check whether db's env uses RPC?
	eval { $self->db_sync } ;

	eval { $self->db_close } ;
	}


package BerkeleyDB::Lite::Hash ;

use BerkeleyDB ;
use Carp ;

our @ISA = qw( BerkeleyDB::Lite ) ;

sub scalars {
	my $invocator = shift ;
	my $class = ref $invocator || $invocator ;
	my( $self, %self ) ;

	my %env = BerkeleyDB::Lite::envsetup( @_ ) ;

	my %alt = @_ ;
	my $filename = $env{filename} ;
	delete $env{filename} ;

	### Table ###
	$self = tie %self, $alt{subclass} || 'BerkeleyDB::Hash',
			%env,
			-Flags => DB_CREATE, 
			or warn "($$) $filename: $!"
			if $env{'-Env'} ;

	## Failsafe- open R/O without locking
	if ( $filename && ! $self ) {
		delete $env{ '-Filename' } ;
		delete $env{ '-Env' } ;
	
		$self = tie %self, 'BerkeleyDB::Hash',
				-Filename => $filename,
				-Flags => DB_RDONLY, 
				%env,
				or warn "$filename: $! (readonly)" ;
		}

	$dbreg{ $self->[0] } = $self if ref $self ;
	return bless \%self, $class ;
	}

Lite.pm  view on Meta::CPAN

use Carp ;

our @ISA = qw( BerkeleyDB::Lite ) ;

sub lexical {
	my $invocator = shift ;
	my $class = ref $invocator || $invocator ;

	return BerkeleyDB::Lite::Btree::Lexical->new( @_ ) ;
	}

sub scalars {
	my $invocator = shift ;
	my $class = ref $invocator || $invocator ;
	my( $self, %self ) ;

	my %env = BerkeleyDB::Lite::envsetup( @_ ) ;

	my %alt = @_ ;
	my $filename = $env{filename} ;
	delete $env{filename} ;

	### Table ###
	$self = tie %self, $alt{subclass} || 'BerkeleyDB::Btree',
			%env,
			-Flags => DB_CREATE, 
			or warn "$filename $!"
			if $env{'-Env'} ;

	## Failsafe- open R/O without locking
	if ( $filename && ! $self ) {
		delete $env{ '-Filename' } ;
		delete $env{ '-Env' } ;
	
		$self = tie %self, 'BerkeleyDB::Btree',
				-Filename => $filename,
				-Flags => DB_RDONLY, 
				%env,
				or warn "$filename $!" ;
		}

	$dbreg{ $self->[0] } = $self if ref $self ;
	return bless \%self, $class ;
	}

sub dosearch {
	my $ref = shift ;
	my $self = tied %$ref ;
	my $partkey = shift ;
	my $isunique = shift ;

	my %unique = () ;
	my @keys = () ;
	my @values = () ;
	my @each = () ;

	return [] unless $partkey ;
	my $length = length $partkey ;

	# database locked
	my $cursor = $self->db_cursor ;

	my $value = 0 ;
	my $key = $partkey ;
	my $status = $cursor->c_get( $key, $value, DB_SET_RANGE ) ;
	
	while ( $key ) {
		last if $status || substr( $key, 0, $length ) ne $partkey ;

		if ( $isunique ) {
			$unique{ $key }++ ;
			}
		else {
			push @each, [ $key, $value ] ;
			}

		$status = $cursor->c_get( $key, $value, DB_NEXT ) ;
		}

	
	$cursor = undef ;
	@each = map { [ $_, $unique{$_} ] } keys %unique if $isunique ;
	return \@each ;
	}

sub matchingkeys {
	return map { $_->[0] } @{ dosearch( @_ ) } ;
	}

sub matchingvalues {
	return map { $_->[1] } @{ dosearch( @_ ) } ;
	}

sub searchset {
	return map { @$_ } @{ dosearch( @_ ) } ;
	}

## intended for Btree's with incremented keys
sub nextrecord {
	my $ref = shift ;
	my $self = tied %$ref ;

	my $key = 0 ;
	my $value = 0 ;
	my $cursor = $self->db_cursor() ;
	$cursor->c_get( $key, $value, DB_LAST ) ;

	$ref->{ $key +1 } = {} ;
	$cursor = undef ;
	return $key +1 ;
	}


package BerkeleyDB::Lite::Btree::Lexical ;
	
our @ISA = qw( BerkeleyDB::Lite::Btree ) ;

sub scalars {
	my $invocator = shift ;
	my $class = ref $invocator || $invocator ;

	my $self = BerkeleyDB::Lite::Btree->scalars( @_ ) ;
	my $ref = tied %$self ;

	return undef unless $ref ;

	$ref->filter_store_key (
			sub {
				$_ = sprintf "%010d", $_ ;
				} ) ;

	$ref->filter_fetch_key (
			sub {
				$_ = sprintf "%d", $_ ;
				} ) ;

	return bless $self, $class ;
	}


1;
__END__
# Below is stub documentation for your module. You better edit it!

=head1 NAME

BerkeleyDB::Lite - Simplified Interface to BerkeleyDB

=head1 SYNOPSIS

  use BerkeleyDB::Lite;


=head2 ## Example 1

  ## Create a Hashed database
  my $db = new BerkeleyDB::Lite::Hash
		home => 'zoo',
		filename => 'residents' ;

  $db->{Samson} = new Primate ;
  $db->{Cornelius} = new Primate ;
  $db->{Kaa} = new Reptile ;


=head2 ## Example 2

  ## Create a Btree database allowing duplicates and scalar values
  my $types = scalars BerkeleyDB::Lite::Btree