# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (Paul.Marquess@btinternet.com)
-# last modified 16th January 2000
-# version 1.72
+# last modified 1st March 2002
+# version 1.804
#
-# Copyright (c) 1995-2000 Paul Marquess. All rights reserved.
+# Copyright (c) 1995-2002 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.003 ;
+require 5.00404;
+use warnings;
use strict;
use Carp;
require Tie::Hash;
package DB_File::RECNOINFO ;
+use warnings;
use strict ;
@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;
package DB_File::BTREEINFO ;
+use warnings;
use strict ;
@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ;
package DB_File ;
+use warnings;
use strict;
-use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO
- $db_version $use_XSLoader
- ) ;
+our ($VERSION, @ISA, @EXPORT, $AUTOLOAD, $DB_BTREE, $DB_HASH, $DB_RECNO);
+our ($db_version, $use_XSLoader, $splice_end_array);
use Carp;
-$VERSION = "1.72" ;
+$VERSION = "1.804" ;
+
+{
+ local $SIG{__WARN__} = sub {$splice_end_array = "@_";};
+ my @a =(1); splice(@a, 3);
+ $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 ;
use AutoLoader;
BEGIN {
$use_XSLoader = 1 ;
- eval { require XSLoader } ;
+ { local $SIG{__DIE__} ; eval { require XSLoader } ; }
if ($@) {
$use_XSLoader = 0 ;
sub AUTOLOAD {
my($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
- my $val = constant($constname, @_ ? $_[0] : 0);
- if ($! != 0) {
- if ($! =~ /Invalid/ || $!{EINVAL}) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
- my($pack,$file,$line) = caller;
- croak "Your vendor has not defined DB macro $constname, used at $file line $line.
-";
- }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
+ my ($error, $val) = constant($constname);
+ Carp::croak $error if $error;
+ no strict 'refs';
+ *{$AUTOLOAD} = sub { $val };
+ goto &{$AUTOLOAD};
+}
eval {
sub CLEAR
{
my $self = shift;
- my $key = "" ;
+ my $key = 0 ;
my $value = "" ;
my $status = $self->seq($key, $value, R_FIRST());
my @keys;
}
}
+
+sub SPLICE
+{
+ my $self = shift;
+ my $offset = shift;
+ if (not defined $offset) {
+ warnings::warnif('uninitialized', 'Use of uninitialized value in splice');
+ $offset = 0;
+ }
+
+ 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 $splice_end_array;
+ }
+
+ # '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"
=head1 SYNOPSIS
- use DB_File ;
-
+ 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 ;
$X->push(list);
$a = $X->shift;
$X->unshift(list);
+ @r = $X->splice(offset, length, elements);
# DBM Filters
$old_filter = $db->filter_store_key ( sub { ... } ) ;
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 3>).
+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.
=back
-=head2 Using DB_File with Berkeley DB version 2 or 3
+=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.or 3 In this case the interface is
+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 3 interface differs, B<DB_File> arranges for it to work
+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 3 without any changes.
+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 in both Berkeley DB
-version 2 and 3. If you cannot recreate your databases, you must dump
-any existing databases with the C<db_dump185> utility that comes with
-Berkeley DB.
-Once you have rebuilt DB_File to use Berkeley DB version 2 or 3, your
-databases can be recreated using C<db_load>. Refer to the Berkeley DB
+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 3.x of Berkeley
+Please read L<"COPYRIGHT"> before using version 2.x or greater of Berkeley
DB with DB_File.
=head2 Interface to Berkeley DB
database, delete keys/value pairs and finally how to enumerate the
contents of the database.
+ use warnings ;
use strict ;
use DB_File ;
- use vars qw( %h $k $v ) ;
+ our (%h, $k, $v) ;
unlink "fruit" ;
- tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $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
here is the output:
Banana Exists
-
+
orange -> orange
tomato -> red
banana -> yellow
BTREE uses. Instead of using the normal lexical ordering, a case
insensitive compare function will be used.
+ use warnings ;
use strict ;
use DB_File ;
$DB_BTREE->{'compare'} = \&Compare ;
unlink "tree" ;
- tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $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
you must use the same compare function every time you access the
database.
+=item 3
+
+Duplicate keys are entirely defined by the comparison function.
+In the case-insensitive example above, the keys: 'KEY' and 'key'
+would be considered duplicates, and assigning to the second one
+would overwrite the first. If duplicates are allowed for (with the
+R_DUPS flag discussed below), only a single copy of duplicate keys
+is stored in the database --- so (again with example above) assigning
+three values to the keys: 'KEY', 'Key', and 'key' would leave just
+the first key: 'KEY' in the database with three values. For some
+situations this results in information loss, so care should be taken
+to provide fully qualified comparison functions when necessary.
+For example, the above comparison routine could be modified to
+additionally compare case-sensitively if two keys are equal in the
+case insensitive comparison:
+
+ sub compare {
+ my($key1, $key2) = @_;
+ lc $key1 cmp lc $key2 ||
+ $key1 cmp $key2;
+ }
+
+And now you will only have duplicates when the keys themselves
+are truly the same. (note: in versions of the db library prior to
+about November 1996, such duplicate keys were retained so it was
+possible to recover the original keys in sets of keys that
+compared as equal).
+
+
=back
=head2 Handling Duplicate Keys
want to manipulate a BTREE database with duplicate keys. Consider this
code:
+ use warnings ;
use strict ;
use DB_File ;
- use vars qw($filename %h ) ;
+ my ($filename, %h) ;
$filename = "tree" ;
unlink $filename ;
-
+
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
-
- tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+
+ 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' ;
$h{'Wall'} = 'Brick' ; # Note the duplicate key
Here is the script above rewritten using the C<seq> API method.
+ use warnings ;
use strict ;
use DB_File ;
-
- use vars qw($filename $x %h $status $key $value) ;
+
+ my ($filename, $x, %h, $status, $key, $value) ;
$filename = "tree" ;
unlink $filename ;
-
+
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
-
- $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+
+ $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' ;
$h{'Wall'} = 'Brick' ; # Note the duplicate key
$h{'Wall'} = 'Brick' ; # Note the duplicate key and value
$h{'Smith'} = 'John' ;
$h{'mouse'} = 'mickey' ;
-
+
# iterate through the btree using seq
# and print each key/value pair.
$key = $value = 0 ;
$status == 0 ;
$status = $x->seq($key, $value, R_NEXT) )
{ print "$key -> $value\n" }
-
+
undef $x ;
untie %h ;
So assuming the database created above, we can use C<get_dup> like
this:
+ use warnings ;
use strict ;
use DB_File ;
-
- use vars qw($filename $x %h ) ;
+
+ my ($filename, $x, %h) ;
$filename = "tree" ;
-
+
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
-
- $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+
+ $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") ;
@list = $x->get_dup("Smith") ;
print "Smith => [@list]\n" ;
-
+
@list = $x->get_dup("Dog") ;
print "Dog => [@list]\n" ;
Assuming the database from the previous example:
+ use warnings ;
use strict ;
use DB_File ;
-
- use vars qw($filename $x %h $found) ;
- my $filename = "tree" ;
-
+ my ($filename, $x, %h, $found) ;
+
+ $filename = "tree" ;
+
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
-
- $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+
+ $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") ;
print "Larry Wall is $found there\n" ;
-
+
$found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ;
print "Harry Wall is $found there\n" ;
-
+
undef $x ;
untie %h ;
Again assuming the existence of the C<tree> database
+ use warnings ;
use strict ;
use DB_File ;
-
- use vars qw($filename $x %h $found) ;
- my $filename = "tree" ;
-
+ my ($filename, $x, %h, $found) ;
+
+ $filename = "tree" ;
+
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
-
- $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+
+ $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") ;
print "Larry Wall is $found there\n" ;
-
+
undef $x ;
untie %h ;
In the example script below, the C<match> sub uses this feature to find
and print the first matching key/value pair given a partial key.
+ use warnings ;
use strict ;
use DB_File ;
use Fcntl ;
- use vars qw($filename $x %h $st $key $value) ;
+ my ($filename, $x, %h, $st, $key, $value) ;
sub match
{
$filename = "tree" ;
unlink $filename ;
- $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ $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{'mouse'} = 'mickey' ;
$h{'Wall'} = 'Larry' ;
$h{'Walls'} = 'Brick' ;
$h{'Smith'} = 'John' ;
-
+
$key = $value = 0 ;
print "IN ORDER\n" ;
for ($st = $x->seq($key, $value, R_FIRST) ;
$st == 0 ;
$st = $x->seq($key, $value, R_NEXT) )
-
+
{ print "$key -> $value\n" }
-
+
print "\nPARTIAL MATCH\n" ;
match "Wa" ;
still have bval default to C<"\n"> for variable length records, and
space for fixed length records.
+Also note that the bval option only allows you to specify a single byte
+as a delimeter.
+
=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
L<Extra RECNO Methods> for a workaround).
+ use warnings ;
use strict ;
use DB_File ;
unlink $filename ;
my @h ;
- tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $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
Returns the number of elements in the array.
+=item B<$X-E<gt>splice(offset, length, elements);>
+
+Returns a splice of the the array.
+
=back
=head2 Another Example
described above. It also makes use of the API interface directly (see
L<THE API INTERFACE>).
+ use warnings ;
use strict ;
- use vars qw(@h $H $file $i) ;
+ my (@h, $H, $file, $i) ;
use DB_File ;
use Fcntl ;
-
+
$file = "text" ;
unlink $file ;
- $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $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
$h[0] = "zero" ;
$h[1] = "one" ;
$h[3] = "three" ;
$h[4] = "four" ;
-
+
# Print the records in order.
#
# The length method is needed here because evaluating a tied
sure you have already guessed, this is a problem that DBM Filters can
fix very easily.
+ use warnings ;
use strict ;
use DB_File ;
Here is a DBM Filter that does it:
+ use warnings ;
use strict ;
use DB_File ;
my %hash ;
The locking technique went like this.
- $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644)
+ $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0666)
|| die "dbcreat /tmp/foo.db $!";
$fd = $db->fd;
open(DB_FH, "+<&=$fd") || die "dup $!";
I<ggh> script (available from your nearest CPAN archive in
F<authors/id/TOMC/scripts/nshist.gz>).
+ use warnings ;
use strict ;
use DB_File ;
use Fcntl ;
- use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ;
+ my ($dotdir, $HISTORY, %hist_db, $href, $binary_time, $date) ;
$dotdir = $ENV{HOME} || $ENV{LOGNAME};
$HISTORY = "$dotdir/.netscape/history.db";
C<strict 'subs'> pragma (or the full strict pragma) in your script.
Consider this script:
+ use warnings ;
use strict ;
use DB_File ;
- use vars qw(%x) ;
+ my %x ;
tie %x, DB_File, "filename" ;
Running it produces the error in question:
=head1 COPYRIGHT
-Copyright (c) 1995-1999 Paul Marquess. All rights reserved. This program
+Copyright (c) 1995-2002 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.
projects / p5sagit/p5-mst-13.2.git / blobdiff