# DB_File.pm -- Perl 5 interface to Berkeley DB 

#

# Written by Paul Marquess (pmqs@cpan.org)

#

#     Copyright (c) 1995-2018 Paul Marquess. 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::HASHINFO ;

require 5.008003;

use warnings;

use strict;

use Carp;

require Tie::Hash;

@DB_File::HASHINFO::ISA = qw(Tie::Hash);

sub new

{

    my $pkg = shift ;

    my %x ;

    tie %x, $pkg ;

    bless \%x, $pkg ;

}

sub TIEHASH

{

    my $pkg = shift ;

    bless { VALID => { 

		       	bsize	  => 1,

			ffactor	  => 1,

			nelem	  => 1,

			cachesize => 1,

			hash	  => 2,

			lorder	  => 1,

		     }, 

	    GOT   => {}

          }, $pkg ;

}

sub FETCH 

{  

    my $self  = shift ;

    my $key   = shift ;

    return $self->{GOT}{$key} if exists $self->{VALID}{$key}  ;

    my $pkg = ref $self ;

    croak "${pkg}::FETCH - Unknown element '$key'" ;

}

sub STORE 

{

    my $self  = shift ;

    my $key   = shift ;

    my $value = shift ;

    my $type = $self->{VALID}{$key};

    if ( $type )

    {

    	croak "Key '$key' not associated with a code reference" 

	    if $type == 2 && !ref $value && ref $value ne 'CODE';

        $self->{GOT}{$key} = $value ;

        return ;

    }

    my $pkg = ref $self ;

    croak "${pkg}::STORE - Unknown element '$key'" ;

}

sub DELETE 

{

    my $self = shift ;

    my $key  = shift ;

    if ( exists $self->{VALID}{$key} )

    {

        delete $self->{GOT}{$key} ;

        return ;

    }

    my $pkg = ref $self ;

    croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ;

}

sub EXISTS

{

    my $self = shift ;

    my $key  = shift ;

    exists $self->{VALID}{$key} ;

}

sub NotHere

{

    my $self = shift ;

    my $method = shift ;

    croak ref($self) . " does not define the method ${method}" ;

}

sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") }

sub NEXTKEY  { my $self = shift ; $self->NotHere("NEXTKEY") }

sub CLEAR    { my $self = shift ; $self->NotHere("CLEAR") }

package DB_File::RECNOINFO ;

use warnings;

use strict ;

@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;

sub TIEHASH

{

    my $pkg = shift ;

    bless { VALID => { map {$_, 1} 

		       qw( bval cachesize psize flags lorder reclen bfname )

		     },

	    GOT   => {},

          }, $pkg ;

}

package DB_File::BTREEINFO ;

use warnings;

use strict ;

@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ;

sub TIEHASH

{

    my $pkg = shift ;

    bless { VALID => { 

		      	flags	   => 1,

			cachesize  => 1,

			maxkeypage => 1,

			minkeypage => 1,

			psize	   => 1,

			compare	   => 2,

			prefix	   => 2,

			lorder	   => 1,

	    	     },

	    GOT   => {},

          }, $pkg ;

}

package DB_File ;

use warnings;

use strict;

our ($VERSION, @ISA, @EXPORT, $AUTOLOAD, $DB_BTREE, $DB_HASH, $DB_RECNO);

our ($db_version, $use_XSLoader, $splice_end_array_no_length, $splice_end_array, $Error);

use Carp;

# Module not thread safe, so don't clone

sub CLONE_SKIP { 1 } 

$VERSION = "1.842" ;

$VERSION = eval $VERSION; # needed for dev releases

{

    local $SIG{__WARN__} = sub {$splice_end_array_no_length = join(" ",@_);};

    my @a =(1); splice(@a, 3);

    $splice_end_array_no_length = 

        ($splice_end_array_no_length =~ /^splice\(\) offset past end of array at /);

}      

{

    local $SIG{__WARN__} = sub {$splice_end_array = join(" ", @_);};

    my @a =(1); splice(@a, 3, 1);

    $splice_end_array = 

        ($splice_end_array =~ /^splice\(\) offset past end of array at /);

}      

#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;

$DB_BTREE = new DB_File::BTREEINFO ;

$DB_HASH  = new DB_File::HASHINFO ;

$DB_RECNO = new DB_File::RECNOINFO ;

require Tie::Hash;

require Exporter;

BEGIN {

    $use_XSLoader = 1 ;

    { local $SIG{__DIE__} ; eval { require XSLoader } ; }

    if ($@) {

        $use_XSLoader = 0 ;

        require DynaLoader;

        @ISA = qw(DynaLoader);

    }

}

push @ISA, qw(Tie::Hash Exporter);

@EXPORT = qw(

        $DB_BTREE $DB_HASH $DB_RECNO 

	BTREEMAGIC

	BTREEVERSION

	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

);

sub AUTOLOAD {

    my($constname);

    ($constname = $AUTOLOAD) =~ s/.*:://;

    my ($error, $val) = constant($constname);

    Carp::croak $error if $error;

    no strict 'refs';

    *{$AUTOLOAD} = sub { $val };

    goto &{$AUTOLOAD};

}           

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);

};

if ($use_XSLoader)

  { XSLoader::load("DB_File", $VERSION)}

else

  { bootstrap DB_File $VERSION }

sub tie_hash_or_array

{

    my (@arg) = @_ ;

    my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ;

    use File::Spec;

    $arg[1] = File::Spec->rel2abs($arg[1]) 

        if defined $arg[1] ;

    $arg[4] = tied %{ $arg[4] } 

	if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ;

    $arg[2] = O_CREAT()|O_RDWR() if @arg >=3 && ! defined $arg[2];

    $arg[3] = 0666               if @arg >=4 && ! defined $arg[3];

    # make recno in Berkeley DB version 2 (or better) work like 

    # recno in version 1.

    if ($db_version >= 4 and ! $tieHASH) {

        $arg[2] |= O_CREAT();

    }

    if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and 

	$arg[1] and ! -e $arg[1]) {

	open(FH, ">$arg[1]") or return undef ;

	close FH ;

	chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ;

    }

    DoTie_($tieHASH, @arg) ;

}

sub TIEHASH

{

    tie_hash_or_array(@_) ;

}

sub TIEARRAY

{

    tie_hash_or_array(@_) ;

}

sub CLEAR 

{

    my $self = shift;

    my $key = 0 ;

    my $value = "" ;

    my $status = $self->seq($key, $value, R_FIRST());

    my @keys;

    while ($status == 0) {

        push @keys, $key;

        $status = $self->seq($key, $value, R_NEXT());

    }

    foreach $key (reverse @keys) {

        my $s = $self->del($key); 

    }

}

sub EXTEND { }

sub STORESIZE

{

    my $self = shift;

    my $length = shift ;

    my $current_length = $self->length() ;

    if ($length < $current_length) {

	my $key ;

        for ($key = $current_length - 1 ; $key >= $length ; -- $key)

	  { $self->del($key) }

    }

    elsif ($length > $current_length) {

        $self->put($length-1, "") ;

    }

}

sub SPLICE

{

    my $self = shift;

    my $offset = shift;

    if (not defined $offset) {

	warnings::warnif('uninitialized', 'Use of uninitialized value in splice');

	$offset = 0;

    }

    my $has_length = @_;

    my $length = @_ ? shift : 0;

    # Carping about definedness comes _after_ the OFFSET sanity check.

    # This is so we get the same error messages as Perl's splice().

    # 

    my @list = @_;

    my $size = $self->FETCHSIZE();

    # 'If OFFSET is negative then it start that far from the end of

    # the array.'

    # 

    if ($offset < 0) {

	my $new_offset = $size + $offset;

	if ($new_offset < 0) {

	    die "Modification of non-creatable array value attempted, "

	      . "subscript $offset";

	}

	$offset = $new_offset;

    }

    if (not defined $length) {

	warnings::warnif('uninitialized', 'Use of uninitialized value in splice');

	$length = 0;

    }

    if ($offset > $size) {

 	$offset = $size;

	warnings::warnif('misc', 'splice() offset past end of array')

            if $has_length ? $splice_end_array : $splice_end_array_no_length;

    }

    # 'If LENGTH is omitted, removes everything from OFFSET onward.'

    if (not defined $length) {

	$length = $size - $offset;

    }

    # 'If LENGTH is negative, leave that many elements off the end of

    # the array.'

    # 

    if ($length < 0) {

	$length = $size - $offset + $length;

	if ($length < 0) {

	    # The user must have specified a length bigger than the

	    # length of the array passed in.  But perl's splice()

	    # doesn't catch this, it just behaves as for length=0.

	    # 

	    $length = 0;

	}

    }

    if ($length > $size - $offset) {

	$length = $size - $offset;

    }

    # $num_elems holds the current number of elements in the database.

    my $num_elems = $size;

    # 'Removes the elements designated by OFFSET and LENGTH from an

    # array,'...

    # 

    my @removed = ();

    foreach (0 .. $length - 1) {

	my $old;

	my $status = $self->get($offset, $old);

	if ($status != 0) {

	    my $msg = "error from Berkeley DB on get($offset, \$old)";

	    if ($status == 1) {

		$msg .= ' (no such element?)';

	    }

	    else {

		$msg .= ": error status $status";

		if (defined $! and $! ne '') {

		    $msg .= ", message $!";

		}

	    }

	    die $msg;

	}

	push @removed, $old;

	$status = $self->del($offset);

	if ($status != 0) {

	    my $msg = "error from Berkeley DB on del($offset)";

	    if ($status == 1) {

		$msg .= ' (no such element?)';

	    }

	    else {

		$msg .= ": error status $status";

		if (defined $! and $! ne '') {

		    $msg .= ", message $!";

		}

	    }

	    die $msg;

	}

	-- $num_elems;

    }

    # ...'and replaces them with the elements of LIST, if any.'

    my $pos = $offset;

    while (defined (my $elem = shift @list)) {

	my $old_pos = $pos;

	my $status;

	if ($pos >= $num_elems) {

	    $status = $self->put($pos, $elem);

	}

	else {

	    $status = $self->put($pos, $elem, $self->R_IBEFORE);

	}

	if ($status != 0) {

	    my $msg = "error from Berkeley DB on put($pos, $elem, ...)";

	    if ($status == 1) {

		$msg .= ' (no such element?)';

	    }

	    else {

		$msg .= ", error status $status";

		if (defined $! and $! ne '') {

		    $msg .= ", message $!";

		}

	    }

	    die $msg;

	}

	die "pos unexpectedly changed from $old_pos to $pos with R_IBEFORE"

	  if $old_pos != $pos;

	++ $pos;

	++ $num_elems;

    }

    if (wantarray) {

	# 'In list context, returns the elements removed from the

	# array.'

	# 

	return @removed;

    }

    elsif (defined wantarray and not wantarray) {

	# 'In scalar context, returns the last element removed, or

	# undef if no elements are removed.'

	# 

	if (@removed) {

	    my $last = pop @removed;

	    return "$last";

	}

	else {

	    return undef;

	}

    }

    elsif (not defined wantarray) {

	# Void context

    }

    else { die }

}

sub ::DB_File::splice { &SPLICE }

sub find_dup

{

    croak "Usage: \$db->find_dup(key,value)\n"

        unless @_ == 3 ;

    my $db        = shift ;

    my ($origkey, $value_wanted) = @_ ;

    my ($key, $value) = ($origkey, 0);

    my ($status) = 0 ;

    for ($status = $db->seq($key, $value, R_CURSOR() ) ;

         $status == 0 ;

         $status = $db->seq($key, $value, R_NEXT() ) ) {

        return 0 if $key eq $origkey and $value eq $value_wanted ;

    }

    return $status ;

}

sub del_dup

{

    croak "Usage: \$db->del_dup(key,value)\n"

        unless @_ == 3 ;

    my $db        = shift ;

    my ($key, $value) = @_ ;

    my ($status) = $db->find_dup($key, $value) ;

    return $status if $status != 0 ;

    $status = $db->del($key, R_CURSOR() ) ;

    return $status ;

}

sub get_dup

{

    croak "Usage: \$db->get_dup(key [,flag])\n"

        unless @_ == 2 or @_ == 3 ;

    my $db        = shift ;

    my $key       = shift ;

    my $flag	  = shift ;

    my $value 	  = 0 ;

    my $origkey   = $key ;

    my $wantarray = wantarray ;

    my %values	  = () ;

    my @values    = () ;

    my $counter   = 0 ;

    my $status    = 0 ;

    # iterate through the database until either EOF ($status == 0)

    # or a different key is encountered ($key ne $origkey).

    for ($status = $db->seq($key, $value, R_CURSOR()) ;

	 $status == 0 and $key eq $origkey ;

         $status = $db->seq($key, $value, R_NEXT()) ) {

        # save the value or count number of matches

        if ($wantarray) {

	    if ($flag)

                { ++ $values{$value} }

	    else

                { push (@values, $value) }

	}

        else

            { ++ $counter }

    }

    return ($wantarray ? ($flag ? %values : @values) : $counter) ;

}

sub STORABLE_freeze

{

    my $type = ref shift;

    croak "Cannot freeze $type object\n";

}

sub STORABLE_thaw

{

    my $type = ref shift;

    croak "Cannot thaw $type object\n";

}

1;

__END__

=head1 NAME

DB_File - Perl5 access to Berkeley DB version 1.x

=head1 SYNOPSIS

 use DB_File;

 [$X =] tie %hash,  'DB_File', [$filename, $flags, $mode, $DB_HASH] ;

 [$X =] tie %hash,  'DB_File', $filename, $flags, $mode, $DB_BTREE ;

 [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ;

 $status = $X->del($key [, $flags]) ;

 $status = $X->put($key, $value [, $flags]) ;

 $status = $X->get($key, $value [, $flags]) ;

 $status = $X->seq($key, $value, $flags) ;

 $status = $X->sync([$flags]) ;

 $status = $X->fd ;

 # BTREE only

 $count = $X->get_dup($key) ;

 @list  = $X->get_dup($key) ;

 %list  = $X->get_dup($key, 1) ;

 $status = $X->find_dup($key, $value) ;

 $status = $X->del_dup($key, $value) ;

 # RECNO only

 $a = $X->length;

 $a = $X->pop ;

 $X->push(list);

 $a = $X->shift;

 $X->unshift(list);

 @r = $X->splice(offset, length, elements);

 # DBM Filters

 $old_filter = $db->filter_store_key  ( sub { ... } ) ;

 $old_filter = $db->filter_store_value( sub { ... } ) ;

 $old_filter = $db->filter_fetch_key  ( sub { ... } ) ;

 $old_filter = $db->filter_fetch_value( sub { ... } ) ;

 untie %hash ;

 untie @array ;

=head1 DESCRIPTION

B<DB_File> is a module which allows Perl programs to make use of the

facilities provided by Berkeley DB version 1.x (if you have a newer

version of DB, see L<Using DB_File with Berkeley DB version 2 or greater>).

It is assumed that you have a copy of the Berkeley DB manual pages at

hand when reading this documentation. The interface defined here

mirrors the Berkeley DB interface closely.

Berkeley DB is a C library which provides a consistent interface to a

number of database formats.  B<DB_File> provides an interface to all

three of the database types currently supported by Berkeley DB.

The file types are:

=over 5

=item B<DB_HASH>

This database type allows arbitrary key/value pairs to be stored in data

files. This is equivalent to the functionality provided by other

hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though,

the files created using DB_HASH are not compatible with any of the

other packages mentioned.

A default hashing algorithm, which will be adequate for most

applications, is built into Berkeley DB. If you do need to use your own

hashing algorithm it is possible to write your own in Perl and have

B<DB_File> use it instead.

=item B<DB_BTREE>

The btree format allows arbitrary key/value pairs to be stored in a

sorted, balanced binary tree.

As with the DB_HASH format, it is possible to provide a user defined

Perl routine to perform the comparison of keys. By default, though, the

keys are stored in lexical order.

=item B<DB_RECNO>

DB_RECNO allows both fixed-length and variable-length flat text files

to be manipulated using the same key/value pair interface as in DB_HASH

and DB_BTREE.  In this case the key will consist of a record (line)

number.

=back

=head2 Using DB_File with Berkeley DB version 2 or greater

Although B<DB_File> is intended to be used with Berkeley DB version 1,

it can also be used with version 2, 3 or 4. In this case the interface is

limited to the functionality provided by Berkeley DB 1.x. Anywhere the

version 2 or greater interface differs, B<DB_File> arranges for it to work

like version 1. This feature allows B<DB_File> scripts that were built

with version 1 to be migrated to version 2 or greater without any changes.

If you want to make use of the new features available in Berkeley DB

2.x or greater, use the Perl module B<BerkeleyDB> instead.

B<Note:> The database file format has changed multiple times in Berkeley

DB version 2, 3 and 4. If you cannot recreate your databases, you

must dump any existing databases with either the C<db_dump> or the

C<db_dump185> utility that comes with Berkeley DB.

Once you have rebuilt DB_File to use Berkeley DB version 2 or greater,

your databases can be recreated using C<db_load>. Refer to the Berkeley DB

documentation for further details.

Please read L<"COPYRIGHT"> before using version 2.x or greater of Berkeley

DB with DB_File.

=head2 Interface to Berkeley DB

B<DB_File> allows access to Berkeley DB files using the tie() mechanism

in Perl 5 (for full details, see L<perlfunc/tie()>). This facility

allows B<DB_File> to access Berkeley DB files using either an

associative array (for DB_HASH & DB_BTREE file types) or an ordinary

array (for the DB_RECNO file type).

In addition to the tie() interface, it is also possible to access most

of the functions provided in the Berkeley DB API directly.

See L<THE API INTERFACE>.

=head2 Opening a Berkeley DB Database File

Berkeley DB uses the function dbopen() to open or create a database.

Here is the C prototype for dbopen():

      DB*

      dbopen (const char * file, int flags, int mode, 

              DBTYPE type, const void * openinfo)

The parameter C<type> is an enumeration which specifies which of the 3

interface methods (DB_HASH, DB_BTREE or DB_RECNO) is to be used.

Depending on which of these is actually chosen, the final parameter,

I<openinfo> points to a data structure which allows tailoring of the

specific interface method.

This interface is handled slightly differently in B<DB_File>. Here is

an equivalent call using B<DB_File>:

        tie %array, 'DB_File', $filename, $flags, $mode, $DB_HASH ;

The C<filename>, C<flags> and C<mode> parameters are the direct

equivalent of their dbopen() counterparts. The final parameter $DB_HASH

performs the function of both the C<type> and C<openinfo> parameters in

dbopen().

In the example above $DB_HASH is actually a pre-defined reference to a

hash object. B<DB_File> has three of these pre-defined references.

Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO.

The keys allowed in each of these pre-defined references is limited to

the names used in the equivalent C structure. So, for example, the

$DB_HASH reference will only allow keys called C<bsize>, C<cachesize>,

C<ffactor>, C<hash>, C<lorder> and C<nelem>. 

To change one of these elements, just assign to it like this:

	$DB_HASH->{'cachesize'} = 10000 ;

The three predefined variables $DB_HASH, $DB_BTREE and $DB_RECNO are

usually adequate for most applications.  If you do need to create extra

instances of these objects, constructors are available for each file

type.

Here are examples of the constructors and the valid options available

for DB_HASH, DB_BTREE and DB_RECNO respectively.

     $a = new DB_File::HASHINFO ;

     $a->{'bsize'} ;

     $a->{'cachesize'} ;

     $a->{'ffactor'};

     $a->{'hash'} ;

     $a->{'lorder'} ;

     $a->{'nelem'} ;

     $b = new DB_File::BTREEINFO ;

     $b->{'flags'} ;

     $b->{'cachesize'} ;

     $b->{'maxkeypage'} ;

     $b->{'minkeypage'} ;

     $b->{'psize'} ;

     $b->{'compare'} ;

     $b->{'prefix'} ;

     $b->{'lorder'} ;

     $c = new DB_File::RECNOINFO ;

     $c->{'bval'} ;

     $c->{'cachesize'} ;

     $c->{'psize'} ;

     $c->{'flags'} ;

     $c->{'lorder'} ;

     $c->{'reclen'} ;

     $c->{'bfname'} ;

The values stored in the hashes above are mostly the direct equivalent

of their C counterpart. Like their C counterparts, all are set to a

default values - that means you don't have to set I<all> of the

values when you only want to change one. Here is an example:

     $a = new DB_File::HASHINFO ;

     $a->{'cachesize'} =  12345 ;

     tie %y, 'DB_File', "filename", $flags, 0777, $a ;

A few of the options need extra discussion here. When used, the C

equivalent of the keys C<hash>, C<compare> and C<prefix> store pointers

to C functions. In B<DB_File> these keys are used to store references

to Perl subs. Below are templates for each of the subs:

    sub hash

    {

        my ($data) = @_ ;

        ...

        # return the hash value for $data

	return $hash ;

    }

    sub compare

    {

	my ($key, $key2) = @_ ;

        ...

        # return  0 if $key1 eq $key2

        #        -1 if $key1 lt $key2

        #         1 if $key1 gt $key2

        return (-1 , 0 or 1) ;

    }

    sub prefix

    {

	my ($key, $key2) = @_ ;

        ...

        # return number of bytes of $key2 which are 

        # necessary to determine that it is greater than $key1

        return $bytes ;

    }

See L<Changing the BTREE sort order> for an example of using the

C<compare> template.

If you are using the DB_RECNO interface and you intend making use of

C<bval>, you should check out L<The 'bval' Option>.

=head2 Default Parameters

It is possible to omit some or all of the final 4 parameters in the

call to C<tie> and let them take default values. As DB_HASH is the most

common file format used, the call:

    tie %A, "DB_File", "filename" ;

is equivalent to:

    tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0666, $DB_HASH ;

It is also possible to omit the filename parameter as well, so the

call:

    tie %A, "DB_File" ;

is equivalent to:

    tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0666, $DB_HASH ;

See L<In Memory Databases> for a discussion on the use of C<undef>

in place of a filename.

=head2 In Memory Databases

Berkeley DB allows the creation of in-memory databases by using NULL

(that is, a C<(char *)0> in C) in place of the filename.  B<DB_File>

uses C<undef> instead of NULL to provide this functionality.

=head1 DB_HASH

The DB_HASH file format is probably the most commonly used of the three

file formats that B<DB_File> supports. It is also very straightforward

to use.

=head2 A Simple Example

This example shows how to create a database, add key/value pairs to the

database, delete keys/value pairs and finally how to enumerate the

contents of the database.