-# DB_File.pm -- Perl 5 interface to Berkeley DB
+# DB_File.pm -- Perl 5 interface to Berkeley DB
#
-# written by Paul Marquess (pmqs@cpan.org)
-# last modified 28th October 2007
-# version 1.818
+# Written by Paul Marquess (pmqs@cpan.org)
#
-# Copyright (c) 1995-2009 Paul Marquess. All rights reserved.
+# Copyright (c) 1995-2020 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.00404;
+require 5.008003;
use warnings;
use strict;
{
my $pkg = shift ;
- bless { VALID => {
- bsize => 1,
- ffactor => 1,
- nelem => 1,
- cachesize => 1,
- hash => 2,
- lorder => 1,
- },
- GOT => {}
+ bless { VALID => {
+ bsize => 1,
+ ffactor => 1,
+ nelem => 1,
+ cachesize => 1,
+ hash => 2,
+ lorder => 1,
+ },
+ GOT => {}
}, $pkg ;
}
-sub FETCH
-{
+sub FETCH
+{
my $self = shift ;
my $key = shift ;
}
-sub STORE
+sub STORE
{
my $self = shift ;
my $key = shift ;
if ( $type )
{
- croak "Key '$key' not associated with a code reference"
- if $type == 2 && !ref $value && ref $value ne 'CODE';
+ 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
+sub DELETE
{
my $self = shift ;
my $key = shift ;
delete $self->{GOT}{$key} ;
return ;
}
-
+
my $pkg = ref $self ;
croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ;
}
{
my $pkg = shift ;
- bless { VALID => { map {$_, 1}
- qw( bval cachesize psize flags lorder reclen bfname )
- },
- GOT => {},
+ bless { VALID => { map {$_, 1}
+ qw( bval cachesize psize flags lorder reclen bfname )
+ },
+ GOT => {},
}, $pkg ;
}
{
my $pkg = shift ;
- bless { VALID => {
- flags => 1,
- cachesize => 1,
- maxkeypage => 1,
- minkeypage => 1,
- psize => 1,
- compare => 2,
- prefix => 2,
- lorder => 1,
- },
- GOT => {},
+ bless { VALID => {
+ flags => 1,
+ cachesize => 1,
+ maxkeypage => 1,
+ minkeypage => 1,
+ psize => 1,
+ compare => 2,
+ prefix => 2,
+ lorder => 1,
+ },
+ GOT => {},
}, $pkg ;
}
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.824" ;
+$VERSION = "1.855" ;
$VERSION = eval $VERSION; # needed for dev releases
{
- local $SIG{__WARN__} = sub {$splice_end_array_no_length = "@_";};
+ 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_end_array_no_length =~ /^splice\(\) offset past end of array at /);
-}
+}
{
- local $SIG{__WARN__} = sub {$splice_end_array = "@_";};
+ local $SIG{__WARN__} = sub {$splice_end_array = join(" ", @_);};
my @a =(1); splice(@a, 3, 1);
- $splice_end_array =
+ $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 ;
+$DB_BTREE = DB_File::BTREEINFO->new();
+$DB_HASH = DB_File::HASHINFO->new();
+$DB_RECNO = DB_File::RECNOINFO->new();
require Tie::Hash;
require Exporter;
-use AutoLoader;
BEGIN {
$use_XSLoader = 1 ;
{ local $SIG{__DIE__} ; eval { require XSLoader } ; }
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
+ $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
);
no strict 'refs';
*{$AUTOLOAD} = sub { $val };
goto &{$AUTOLOAD};
-}
+}
eval {
if ($use_XSLoader)
{ XSLoader::load("DB_File", $VERSION)}
else
- { bootstrap DB_File $VERSION }
-
-# Preloaded methods go here. Autoload methods go after __END__, and are
-# processed by the autosplit program.
+ { DB_File->bootstrap( $VERSION ) }
sub tie_hash_or_array
{
my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ;
use File::Spec;
- $arg[1] = File::Spec->rel2abs($arg[1])
+ $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[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
+ # 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] ;
+ 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) ;
tie_hash_or_array(@_) ;
}
-sub CLEAR
+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);
+ my $s = $self->del($key);
}
}
my $current_length = $self->length() ;
if ($length < $current_length) {
- my $key ;
+ my $key ;
for ($key = $current_length - 1 ; $key >= $length ; -- $key)
- { $self->del($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;
+ 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;
+ 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;
+ 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')
+ $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;
+ $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;
- }
+ $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;
+ $length = $size - $offset;
}
# $num_elems holds the current number of elements in the database.
# '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;
+ 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;
+ 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;
+ # '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;
- }
+ # '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
+ # Void context
}
else { die }
}
{
croak "Usage: \$db->find_dup(key,value)\n"
unless @_ == 3 ;
-
+
my $db = shift ;
my ($origkey, $value_wanted) = @_ ;
my ($key, $value) = ($origkey, 0);
{
croak "Usage: \$db->del_dup(key,value)\n"
unless @_ == 3 ;
-
+
my $db = shift ;
my ($key, $value) = @_ ;
my ($status) = $db->find_dup($key, $value) ;
{
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 $flag = shift ;
+ my $value = 0 ;
my $origkey = $key ;
my $wantarray = wantarray ;
- my %values = () ;
+ 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 == 0 and $key eq $origkey ;
$status = $db->seq($key, $value, R_NEXT()) ) {
-
+
# save the value or count number of matches
if ($wantarray) {
- if ($flag)
+ if ($flag)
{ ++ $values{$value} }
- else
+ else
{ push (@values, $value) }
- }
+ }
else
{ ++ $counter }
-
+
}
-
+
return ($wantarray ? ($flag ? %values : @values) : $counter) ;
}
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.
+2.x or greater, use the Perl module L<BerkeleyDB|https://metacpan.org/pod/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
Here is the C prototype for dbopen():
DB*
- dbopen (const char * file, int flags, int mode,
+ 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
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>.
+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 ;
+ $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
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 = DB_File::HASHINFO->new();
$a->{'bsize'} ;
$a->{'cachesize'} ;
$a->{'ffactor'};
$a->{'lorder'} ;
$a->{'nelem'} ;
- $b = new DB_File::BTREEINFO ;
+ $b = DB_File::BTREEINFO->new();
$b->{'flags'} ;
$b->{'cachesize'} ;
$b->{'maxkeypage'} ;
$b->{'prefix'} ;
$b->{'lorder'} ;
- $c = new DB_File::RECNOINFO ;
+ $c = DB_File::RECNOINFO->new();
$c->{'bval'} ;
$c->{'cachesize'} ;
$c->{'psize'} ;
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 = DB_File::HASHINFO->new();
$a->{'cachesize'} = 12345 ;
tie %y, 'DB_File', "filename", $flags, 0777, $a ;
my ($data) = @_ ;
...
# return the hash value for $data
- return $hash ;
+ return $hash ;
}
sub compare
{
- my ($key, $key2) = @_ ;
+ my ($key, $key2) = @_ ;
...
# return 0 if $key1 eq $key2
# -1 if $key1 lt $key2
sub prefix
{
- my ($key, $key2) = @_ ;
+ my ($key, $key2) = @_ ;
...
- # return number of bytes of $key2 which are
+ # return number of bytes of $key2 which are
# necessary to determine that it is greater than $key1
return $bytes ;
}
our (%h, $k, $v) ;
unlink "fruit" ;
- tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0666, $DB_HASH
+ tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0666, $DB_HASH
or die "Cannot open file 'fruit': $!\n";
# Add a few key/value pairs to the file
$DB_BTREE->{'compare'} = \&Compare ;
unlink "tree" ;
- tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0666, $DB_BTREE
+ tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0666, $DB_BTREE
or die "Cannot open file 'tree': $!\n" ;
# Add a key/value pair to the file
compared as equal).
-=back
+=back
-=head2 Handling Duplicate Keys
+=head2 Handling Duplicate Keys
The BTREE file type optionally allows a single key to be associated
with an arbitrary number of values. This option is enabled by setting
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
- tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
- or die "Cannot open $filename: $!\n";
+ tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
# Add some key/value pairs to the file
$h{'Wall'} = 'Larry' ;
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
- $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
- or die "Cannot open $filename: $!\n";
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
# Add some key/value pairs to the file
$h{'Wall'} = 'Larry' ;
This time we have got all the key/value pairs, including the multiple
values associated with the key C<Wall>.
-To make life easier when dealing with duplicate keys, B<DB_File> comes with
+To make life easier when dealing with duplicate keys, B<DB_File> comes with
a few utility methods.
=head2 The get_dup() Method
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
- $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
- or die "Cannot open $filename: $!\n";
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
my $cnt = $x->get_dup("Wall") ;
print "Wall occurred $cnt times\n" ;
print "There are $hash{'Brick'} Brick Walls\n" ;
my @list = sort $x->get_dup("Wall") ;
- print "Wall => [@list]\n" ;
+ print "Wall => [@list]\n" ;
@list = $x->get_dup("Smith") ;
- print "Smith => [@list]\n" ;
+ print "Smith => [@list]\n" ;
@list = $x->get_dup("Dog") ;
- print "Dog => [@list]\n" ;
+ print "Dog => [@list]\n" ;
and it will print:
Wall occurred 3 times
Larry is there
There are 2 Brick Walls
- Wall => [Brick Brick Larry]
- Smith => [John]
- Dog => []
+ Wall => [Brick Brick Larry]
+ Smith => [John]
+ Dog => []
=head2 The find_dup() Method
$status = $X->find_dup($key, $value) ;
This method checks for the existence of a specific key/value pair. If the
-pair exists, the cursor is left pointing to the pair and the method
+pair exists, the cursor is left pointing to the pair and the method
returns 0. Otherwise the method returns a non-zero value.
Assuming the database from the previous example:
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
- $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
- or die "Cannot open $filename: $!\n";
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
- $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
+ $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
print "Larry Wall is $found there\n" ;
- $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ;
+ $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ;
print "Harry Wall is $found there\n" ;
undef $x ;
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
- $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
- or die "Cannot open $filename: $!\n";
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
$x->del_dup("Wall", "Larry") ;
- $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
+ $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
print "Larry Wall is $found there\n" ;
undef $x ;
Larry Wall is not there
-=head2 Matching Partial Keys
+=head2 Matching Partial Keys
The BTREE interface has a feature which allows partial keys to be
matched. This functionality is I<only> available when the C<seq> method
# Add some key/value pairs to the file
$h{'mouse'} = 'mickey' ;
$h{'Wall'} = 'Larry' ;
- $h{'Walls'} = 'Brick' ;
+ $h{'Walls'} = 'Brick' ;
$h{'Smith'} = 'John' ;
$key = $value = 0 ;
print "IN ORDER\n" ;
for ($st = $x->seq($key, $value, R_FIRST) ;
- $st == 0 ;
+ $st == 0 ;
$st = $x->seq($key, $value, R_NEXT) )
- { print "$key -> $value\n" }
+ { print "$key -> $value\n" }
print "\nPARTIAL MATCH\n" ;
=head2 A Simple Example
-Here is a simple example that uses RECNO (if you are using a version
-of Perl earlier than 5.004_57 this example won't work -- see
+Here is a simple example that uses RECNO (if you are using a version
+of Perl earlier than 5.004_57 this example won't work -- see
L<Extra RECNO Methods> for a workaround).
use warnings ;
unlink $filename ;
my @h ;
- tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_RECNO
+ tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_RECNO
or die "Cannot open file 'text': $!\n" ;
# Add a few key/value pairs to the file
=head2 Another Example
Here is a more complete example that makes use of some of the methods
-described above. It also makes use of the API interface directly (see
+described above. It also makes use of the API interface directly (see
L<THE API INTERFACE>).
use warnings ;
unlink $file ;
- $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0666, $DB_RECNO
+ $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0666, $DB_RECNO
or die "Cannot open file $file: $!\n" ;
# first create a text file to play with
#
# The length method is needed here because evaluating a tied
# array in a scalar context does not return the number of
- # elements in the array.
+ # elements in the array.
print "\nORIGINAL\n" ;
foreach $i (0 .. $H->length - 1) {
# same again, but use the API functions instead
print "\nREVERSE again\n" ;
my ($s, $k, $v) = (0, 0, 0) ;
- for ($s = $H->seq($k, $v, R_LAST) ;
- $s == 0 ;
+ for ($s = $H->seq($k, $v, R_LAST) ;
+ $s == 0 ;
$s = $H->seq($k, $v, R_PREV))
{ print "$k: $v\n" }
it is necessary to use either this:
- foreach $i (0 .. $H->length - 1)
+ foreach $i (0 .. $H->length - 1)
or this:
To do this you need to store a copy of the object returned from the tie.
- $db = tie %hash, "DB_File", "filename" ;
+ $db = tie %hash, "DB_File", "filename" ;
Once you have done that, you can access the Berkeley DB API functions
as B<DB_File> methods directly like this:
- $db->put($key, $value, R_NOOVERWRITE) ;
+ $db->put($key, $value, R_NOOVERWRITE) ;
B<Important:> If you have saved a copy of the object returned from
C<tie>, the underlying database file will I<not> be closed until both
the tied variable is untied and all copies of the saved object are
-destroyed.
+destroyed.
use DB_File ;
- $db = tie %hash, "DB_File", "filename"
+ $db = tie %hash, "DB_File", "filename"
or die "Cannot tie filename: $!" ;
...
undef $db ;
$X->seq($key, $value, R_FIRST) ;
# this line will modify the cursor
- $count = scalar keys %x ;
+ $count = scalar keys %x ;
# Get the second key/value pair.
# oops, it didn't, it got the last key/value pair!
or die "Cannot tie $filename: $!" ;
# this line will modify the cursor
- $count = scalar keys %x ;
+ $count = scalar keys %x ;
# Get the first key/value pair and set the cursor
$X->seq($key, $value, R_FIRST) ;
=head1 DBM FILTERS
-A DBM Filter is a piece of code that is be used when you I<always>
-want to make the same transformation to all keys and/or values in a
-DBM database.
+A DBM Filter is a piece of code that is be used when you I<always> want to
+make the same transformation to all keys and/or values in a DBM database.
+An example is when you need to encode your data in UTF-8 before writing to
+the database and then decode the UTF-8 when reading from the database file.
+
+There are two ways to use a DBM Filter.
+
+=over 5
+
+=item 1.
+
+Using the low-level API defined below.
+
+=item 2.
+
+Using the L<DBM_Filter> module.
+This module hides the complexity of the API defined below and comes
+with a number of "canned" filters that cover some of the common use-cases.
+
+=back
+
+Use of the L<DBM_Filter> module is recommended.
+
+=head2 DBM Filter Low-level API
There are four methods associated with DBM Filters. All work identically,
and each is used to install (or uninstall) a single DBM Filter. Each
my $filename = "filt" ;
unlink $filename ;
- my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH
+ my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH
or die "Cannot open $filename: $!\n" ;
# Install DBM Filters
unlink $filename ;
- my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH
+ my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH
or die "Cannot open $filename: $!\n" ;
$db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ;
the contents of the key, so it wasn't necessary to install any value
filters.
-=head1 HINTS AND TIPS
+=head1 HINTS AND TIPS
=head2 Locking: The Trouble with fd
flawed (Kudos to David Harris for tracking this down). Use it at your own
peril!
-The locking technique went like this.
+The locking technique went like this.
$db = tie(%db, 'DB_File', 'foo.db', O_CREAT|O_RDWR, 0644)
|| die "dbcreat foo.db $!";
=head2 Safe ways to lock a database
Starting with version 2.x, Berkeley DB has internal support for locking.
-The companion module to this one, B<BerkeleyDB>, provides an interface
+The companion module to this one, L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB>, provides an interface
to this locking functionality. If you are serious about locking
-Berkeley DB databases, I strongly recommend using B<BerkeleyDB>.
+Berkeley DB databases, I strongly recommend using L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB>.
-If using B<BerkeleyDB> isn't an option, there are a number of modules
+If using L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB> isn't an option, there are a number of modules
available on CPAN that can be used to implement locking. Each one
implements locking differently and has different goals in mind. It is
therefore worth knowing the difference, so that you can pick the right
system. However, updates are still serial. Use for databases where reads
may be lengthy and consistency problems may occur.
-=item B<Tie::DB_LockFile>
+=item B<Tie::DB_LockFile>
A B<DB_File> wrapper that has the ability to lock and unlock the database
while it is being used. Avoids the tie-before-flock problem by simply
updates and/or reads if the application follows the hints in the POD
documentation.
-=item B<DB_File::Lock>
+=item B<DB_File::Lock>
An extremely lightweight B<DB_File> wrapper that simply flocks a lockfile
before tie-ing the database and drops the lock after the untie. Allows
=head2 The untie() Gotcha
If you make use of the Berkeley DB API, it is I<very> strongly
-recommended that you read L<perltie/The untie Gotcha>.
+recommended that you read L<perltie/The untie Gotcha>.
Even if you don't currently make use of the API interface, it is still
worth reading it.
Check out the MLDBM module, available on CPAN in the directory
F<modules/by-module/MLDBM>.
+=head2 What does "wide character in subroutine entry" mean?
+
+You will usually get this message if you are working with UTF-8 data and
+want to read/write it from/to a Berkeley DB database file.
+
+The easist way to deal with this issue is to use the pre-defined "utf8"
+B<DBM_Filter> (see L<DBM_Filter>) that was designed to deal with this
+situation.
+
+The example below shows what you need if I<both> the key and value are
+expected to be in UTF-8.
+
+ use DB_File;
+ use DBM_Filter;
+
+ my $db = tie %h, 'DB_File', '/tmp/try.db', O_CREAT|O_RDWR, 0666, $DB_BTREE;
+ $db->Filter_Key_Push('utf8');
+ $db->Filter_Value_Push('utf8');
+
+ my $key = "\N{LATIN SMALL LETTER A WITH ACUTE}";
+ my $value = "\N{LATIN SMALL LETTER E WITH ACUTE}";
+ $h{ $key } = $value;
+
=head2 What does "Invalid Argument" mean?
You will get this error message when one of the parameters in the
=item 1.
-Attempting to reopen a database without closing it.
+Attempting to reopen a database without closing it.
=item 2.
=back
-=head2 What does "Bareword 'DB_File' not allowed" mean?
+=head2 What does "Bareword 'DB_File' not allowed" mean?
You will encounter this particular error message when you have the
C<strict 'subs'> pragma (or the full strict pragma) in your script.
Running it produces the error in question:
- Bareword "DB_File" not allowed while "strict subs" in use
+ Bareword "DB_File" not allowed while "strict subs" in use
To get around the error, place the word C<DB_File> in either single or
double quotes, like this:
I am sure there are bugs in the code. If you do find any, or can
suggest any enhancements, I would welcome your comments.
+=head1 SUPPORT
+
+General feedback/questions/bug reports should be sent to
+L<https://github.com/pmqs/DB_File/issues> (preferred) or
+L<https://rt.cpan.org/Public/Dist/Display.html?Name=DB_File>.
+
=head1 AVAILABILITY
B<DB_File> comes with the standard Perl source distribution. Look in
L<perlmodlib/CPAN> for details), in the directory
F<modules/by-module/DB_File>.
-This version of B<DB_File> will work with either version 1.x, 2.x or
-3.x of Berkeley DB, but is limited to the functionality provided by
-version 1.
+B<DB_File> is designed to work with any version of Berkeley DB, but is limited to the functionality provided by
+version 1. If you want to make use of the new features available in Berkeley DB
+2.x, or greater, use the Perl module L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB> instead.
-The official web site for Berkeley DB is F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>.
+The official web site for Berkeley DB is L<http://www.oracle.com/technology/products/berkeley-db/db/index.html>.
All versions of Berkeley DB are available there.
Alternatively, Berkeley DB version 1 is available at your nearest CPAN
=head1 COPYRIGHT
-Copyright (c) 1995-2007 Paul Marquess. All rights reserved. This program
+Copyright (c) 1995-2020 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.
makes use of, namely Berkeley DB, is not. Berkeley DB has its own
copyright and its own license. Please take the time to read it.
-Here are are few words taken from the Berkeley DB FAQ (at
-F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>) regarding the license:
+Here are a few words taken from the Berkeley DB FAQ (at
+L<http://www.oracle.com/technology/products/berkeley-db/db/index.html>) regarding the license:
- Do I have to license DB to use it in Perl scripts?
+ Do I have to license DB to use it in Perl scripts?
No. The Berkeley DB license requires that software that uses
Berkeley DB be freely redistributable. In the case of Perl, that
=head1 SEE ALSO
L<perl>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>,
-L<perldbmfilter>
+L<perldbmfilter>, L<DBM_Filter>
=head1 AUTHOR
https://perl5.git.perl.org / perl5.git / blobdiff