X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FDB_File%2FDB_File.pm;h=5ac1120b1792aaf0a0d5a241bd1ab36b4d9b50a4;hb=0d73bec8afda581f611a829e9b78bcf09d06a888;hp=a1ec0e6362c42d6bc3c921e75477aeb86315f307;hpb=ee8c7f5465f003860e2347a2946abacac39bd9b9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index a1ec0e6..5ac1120 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,10 +1,10 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (Paul.Marquess@btinternet.com) -# last modified 26th April 2000 -# version 1.73 +# last modified 30th July 2001 +# version 1.78 # -# Copyright (c) 1995-2000 Paul Marquess. All rights reserved. +# Copyright (c) 1995-2001 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. @@ -13,6 +13,7 @@ package DB_File::HASHINFO ; require 5.003 ; +use warnings; use strict; use Carp; require Tie::Hash; @@ -104,6 +105,7 @@ sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } package DB_File::RECNOINFO ; +use warnings; use strict ; @DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; @@ -121,6 +123,7 @@ sub TIEHASH package DB_File::BTREEINFO ; +use warnings; use strict ; @DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ; @@ -140,6 +143,7 @@ sub TIEHASH package DB_File ; +use warnings; use strict; use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_version $use_XSLoader @@ -147,7 +151,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO use Carp; -$VERSION = "1.73" ; +$VERSION = "1.78" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; @@ -218,8 +222,9 @@ sub AUTOLOAD { "; } } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; + no strict 'refs'; + *{$AUTOLOAD} = sub { $val }; + goto &{$AUTOLOAD}; } @@ -271,7 +276,7 @@ sub TIEARRAY sub CLEAR { my $self = shift; - my $key = "" ; + my $key = 0 ; my $value = "" ; my $status = $self->seq($key, $value, R_FIRST()); my @keys; @@ -303,6 +308,171 @@ sub STORESIZE } } + +sub SPLICE +{ + my $self = shift; + my $offset = shift; + if (not defined $offset) { + carp '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 ($offset > $size) { + $offset = $size; + } + + if (not defined $length) { + carp 'Use of uninitialized value in splice'; + $length = 0; + } + + # '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" @@ -384,8 +554,8 @@ DB_File - Perl5 access to Berkeley DB version 1.x =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 ; @@ -410,6 +580,7 @@ DB_File - Perl5 access to Berkeley DB version 1.x $X->push(list); $a = $X->shift; $X->unshift(list); + @r = $X->splice(offset, length, elements); # DBM Filters $old_filter = $db->filter_store_key ( sub { ... } ) ; @@ -471,7 +642,7 @@ number. =head2 Using DB_File with Berkeley DB version 2 or 3 Although B 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 or 3. 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 arranges for it to work like version 1. This feature allows B scripts that were built @@ -482,8 +653,8 @@ If you want to make use of the new features available in Berkeley DB B 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 utility that comes with -Berkeley DB. +any existing databases with either the C or the C +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. Refer to the Berkeley DB documentation for further details. @@ -665,12 +836,13 @@ 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. + use warnings ; use strict ; use DB_File ; use vars qw( %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 @@ -694,7 +866,7 @@ contents of the database. here is the output: Banana Exists - + orange -> orange tomato -> red banana -> yellow @@ -715,6 +887,7 @@ This script shows how to override the default sorting algorithm that BTREE uses. Instead of using the normal lexical ordering, a case insensitive compare function will be used. + use warnings ; use strict ; use DB_File ; @@ -730,7 +903,7 @@ insensitive compare function will be used. $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 @@ -771,6 +944,35 @@ You cannot change the ordering once the database has been created. Thus 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 @@ -783,6 +985,7 @@ There are some difficulties in using the tied hash interface if you want to manipulate a BTREE database with duplicate keys. Consider this code: + use warnings ; use strict ; use DB_File ; @@ -790,13 +993,13 @@ code: $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 @@ -837,27 +1040,28 @@ and the API in general. Here is the script above rewritten using the C API method. + use warnings ; use strict ; use DB_File ; - + use vars qw($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 ; @@ -865,7 +1069,7 @@ Here is the script above rewritten using the C API method. $status == 0 ; $status = $x->seq($key, $value, R_NEXT) ) { print "$key -> $value\n" } - + undef $x ; untie %h ; @@ -908,17 +1112,18 @@ particular value occurred in the BTREE. So assuming the database created above, we can use C like this: + use warnings ; use strict ; use DB_File ; - + use vars qw($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") ; @@ -933,7 +1138,7 @@ this: @list = $x->get_dup("Smith") ; print "Smith => [@list]\n" ; - + @list = $x->get_dup("Dog") ; print "Dog => [@list]\n" ; @@ -957,25 +1162,26 @@ returns 0. Otherwise the method returns a non-zero value. Assuming the database from the previous example: + use warnings ; use strict ; use DB_File ; - + use vars qw($filename $x %h $found) ; my $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 ; @@ -995,24 +1201,25 @@ Otherwise the method returns a non-zero value. Again assuming the existence of the C database + use warnings ; use strict ; use DB_File ; - + use vars qw($filename $x %h $found) ; my $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 ; @@ -1039,6 +1246,7 @@ the use of the R_CURSOR flag with seq: In the example script below, the C 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 ; @@ -1057,24 +1265,24 @@ and print the first matching key/value pair given a partial key. $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" ; @@ -1137,12 +1345,16 @@ That means that you can specify other options (e.g. cachesize) and 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 for a workaround). + use warnings ; use strict ; use DB_File ; @@ -1150,7 +1362,7 @@ L for a workaround). 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 @@ -1224,6 +1436,10 @@ Pushes the elements of C to the start of the array. Returns the number of elements in the array. +=item B<$X-Esplice(offset, length, elements);> + +Returns a splice of the the array. + =back =head2 Another Example @@ -1232,18 +1448,19 @@ 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 L). + use warnings ; use strict ; use vars qw(@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" ; @@ -1251,7 +1468,7 @@ L). $h[3] = "three" ; $h[4] = "four" ; - + # Print the records in order. # # The length method is needed here because evaluating a tied @@ -1583,6 +1800,7 @@ the database and have them removed when you read from the database. As I'm sure you have already guessed, this is a problem that DBM Filters can fix very easily. + use warnings ; use strict ; use DB_File ; @@ -1625,6 +1843,7 @@ when reading. Here is a DBM Filter that does it: + use warnings ; use strict ; use DB_File ; my %hash ; @@ -1659,7 +1878,7 @@ peril! 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 $!"; @@ -1791,6 +2010,7 @@ Here is a snippet of code that is loosely based on Tom Christiansen's I script (available from your nearest CPAN archive in F). + use warnings ; use strict ; use DB_File ; use Fcntl ; @@ -1947,6 +2167,7 @@ You will encounter this particular error message when you have the C pragma (or the full strict pragma) in your script. Consider this script: + use warnings ; use strict ; use DB_File ; use vars qw(%x) ; @@ -2015,7 +2236,7 @@ compile properly on IRIX 5.3. =head1 COPYRIGHT -Copyright (c) 1995-1999 Paul Marquess. All rights reserved. This program +Copyright (c) 1995-2001 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.