diff options
Diffstat (limited to 'contrib/perl5/ext/DB_File')
| -rw-r--r-- | contrib/perl5/ext/DB_File/Changes | 205 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/DB_File.pm | 1695 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/DB_File.xs | 1497 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/DB_File_BS | 6 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/Makefile.PL | 20 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/dbinfo | 96 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/typemap | 41 |
7 files changed, 3560 insertions, 0 deletions
diff --git a/contrib/perl5/ext/DB_File/Changes b/contrib/perl5/ext/DB_File/Changes new file mode 100644 index 0000000..993fe32 --- /dev/null +++ b/contrib/perl5/ext/DB_File/Changes @@ -0,0 +1,205 @@ + +0.1 + + First Release. + +0.2 + + When DB_File is opening a database file it no longer terminates the + process if dbopen returned an error. This allows file protection + errors to be caught at run time. Thanks to Judith Grass + <grass@cybercash.com> for spotting the bug. + +0.3 + + Added prototype support for multiple btree compare callbacks. + +1.0 + + DB_File has been in use for over a year. To reflect that, the + version number has been incremented to 1.0. + + Added complete support for multiple concurrent callbacks. + + Using the push method on an empty list didn't work properly. This + has been fixed. + +1.01 + + Fixed a core dump problem with SunOS. + + The return value from TIEHASH wasn't set to NULL when dbopen + returned an error. + +1.02 + + Merged OS/2 specific code into DB_File.xs + + Removed some redundant code in DB_File.xs. + + Documentation update. + + Allow negative subscripts with RECNO interface. + + Changed the default flags from O_RDWR to O_CREAT|O_RDWR. + + The example code which showed how to lock a database needed a call + to sync added. Without it the resultant database file was empty. + + Added get_dup method. + +1.03 + + Documentation update. + + DB_File now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl + automatically. + + The standard hash function exists is now supported. + + Modified the behavior of get_dup. When it returns an associative + array, the value is the count of the number of matching BTREE + values. + +1.04 + + Minor documentation changes. + + Fixed a bug in hash_cb. Patches supplied by Dave Hammen, + <hammen@gothamcity.jsc.nasa.govt>. + + Fixed a bug with the constructors for DB_File::HASHINFO, + DB_File::BTREEINFO and DB_File::RECNOINFO. Also tidied up the + constructors to make them -w clean. + + Reworked part of the test harness to be more locale friendly. + +1.05 + + Made all scripts in the documentation strict and -w clean. + + Added logic to DB_File.xs to allow the module to be built after + Perl is installed. + +1.06 + + Minor namespace cleanup: Localized PrintBtree. + +1.07 + + Fixed bug with RECNO, where bval wasn't defaulting to "\n". + +1.08 + + Documented operation of bval. + +1.09 + + Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and + DB_File::BTREEINFO. + + Changed default mode to 0666. + +1.10 + + Fixed fd method so that it still returns -1 for in-memory files + when db 1.86 is used. + +1.11 + + Documented the untie gotcha. + +1.12 + + Documented the incompatibility with version 2 of Berkeley DB. + +1.13 + + Minor changes to DB_FIle.xs and DB_File.pm + +1.14 + + Made it illegal to tie an associative array to a RECNO database and + an ordinary array to a HASH or BTREE database. + +1.15 + + Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined + value" warning with db_get and db_seq. + + Patch from Gisle Aas <gisle@aas.no> to make DB_File export only the + O_* constants from Fcntl. + + Removed the DESTROY method from the DB_File::HASHINFO module. + + Previously DB_File hard-wired the class name of any object that it + created to "DB_File". This makes sub-classing difficult. Now + DB_File creats objects in the namespace of the package it has been + inherited into. + + +1.16 + + A harmless looking tab was causing Makefile.PL to fail on AIX 3.2.5 + + Small fix for the AIX strict C compiler XLC which doesn't like + __attribute__ being defined via proto.h and redefined via db.h. Fix + courtesy of Jarkko Hietaniemi. + +1.50 + + DB_File can now build with either DB 1.x or 2.x, but not both at + the same time. + +1.51 + + Fixed the test harness so that it doesn't expect DB_File to have + been installed by the main Perl build. + + + Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent + +1.52 + + Patch from Nick Ing-Simmons now allows DB_File to build on NT. + Merged 1.15 patch. + +1.53 + + Added DB_RENUMBER to flags for recno. + +1.54 + + Fixed a small bug in the test harness when run under win32 + The emulation of fd when useing DB 2.x was busted. + +1.55 + Merged 1.16 changes. + +1.56 + Documented the Solaris 2.5 mutex bug + +1.57 + If Perl has been compiled with Threads support,the symbol op will be + defined. This clashes with a field name in db.h, so it needs to be + #undef'ed before db.h is included. + +1.58 + Tied Array support was enhanced in Perl 5.004_57. DB_File now + supports PUSH,POP,SHIFT,UNSHIFT & STORESIZE. + + Fixed a problem with the use of sv_setpvn. When the size is + specified as 0, it does a strlen on the data. This was ok for DB + 1.x, but isn't for DB 2.x. + +1.59 + Updated the license section. + + Berkeley DB 2.4.10 disallows zero length keys. Tests 32 & 42 in + db-btree.t and test 27 in db-hash.t failed because of this change. + Those tests have been zapped. + + Added dbinfo to the distribution. + +1.60 + Changed the test to check for full tied array support diff --git a/contrib/perl5/ext/DB_File/DB_File.pm b/contrib/perl5/ext/DB_File/DB_File.pm new file mode 100644 index 0000000..fcd0746 --- /dev/null +++ b/contrib/perl5/ext/DB_File/DB_File.pm @@ -0,0 +1,1695 @@ +# DB_File.pm -- Perl 5 interface to Berkeley DB +# +# written by Paul Marquess (pmarquess@bfsec.bt.co.uk) +# last modified 16th May 1998 +# version 1.60 +# +# Copyright (c) 1995-8 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 ; + +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 => { map {$_, 1} + qw( bsize ffactor nelem cachesize hash lorder) + }, + 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 ; + + if ( exists $self->{VALID}{$key} ) + { + $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 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 strict ; + +@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ; + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { map {$_, 1} + qw( flags cachesize maxkeypage minkeypage psize + compare prefix lorder ) + }, + GOT => {}, + }, $pkg ; +} + + +package DB_File ; + +use strict; +use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_version) ; +use Carp; + + +$VERSION = "1.60" ; + +#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; +use AutoLoader; +require DynaLoader; +@ISA = qw(Tie::Hash Exporter DynaLoader); +@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 $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $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; +} + + +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); +}; + +## import borrowed from IO::File +## exports Fcntl constants if available. +#sub import { +# my $pkg = shift; +# my $callpkg = caller; +# Exporter::export $pkg, $callpkg, @_; +# eval { +# require Fcntl; +# Exporter::export 'Fcntl', $callpkg, '/^O_/'; +# }; +#} + +bootstrap DB_File $VERSION; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +sub tie_hash_or_array +{ + my (@arg) = @_ ; + my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ; + + $arg[4] = tied %{ $arg[4] } + if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; + + # make recno in Berkeley DB version 2 work like recno in version 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) ; +} + +sub TIEHASH +{ + tie_hash_or_array(@_) ; +} + +sub TIEARRAY +{ + tie_hash_or_array(@_) ; +} + +sub CLEAR +{ + my $self = shift; + my $key = "" ; + 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 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) ; +} + + +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) ; + + # RECNO only + $a = $X->length; + $a = $X->pop ; + $X->push(list); + $a = $X->shift; + $X->unshift(list); + + 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>). 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 + +Although B<DB_File> is intended to be used with Berkeley DB version 1, +it can also be used with version 2. In this case the interface is +limited to the functionality provided by Berkeley DB 1.x. Anywhere the +version 2 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 without any changes. + +If you want to make use of the new features available in Berkeley DB +2.x, use the Perl module B<BerkeleyDB> instead. + +At the time of writing this document the B<BerkeleyDB> module is still +alpha quality (the version number is < 1.0), and so unsuitable for use +in any serious development work. Once its version number is >= 1.0, it +is considered stable enough for real work. + +B<Note:> The database file format has changed in Berkeley DB version 2. +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 upgraded DB_File to use Berkeley DB version 2, 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 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. + + use strict ; + use DB_File ; + use vars qw( %h $k $v ) ; + + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH + or die "Cannot open file 'fruit': $!\n"; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + +here is the output: + + Banana Exists + + orange -> orange + tomato -> red + banana -> yellow + +Note that the like ordinary associative arrays, the order of the keys +retrieved is in an apparently random order. + +=head1 DB_BTREE + +The DB_BTREE format is useful when you want to store data in a given +order. By default the keys will be stored in lexical order, but as you +will see from the example shown in the next section, it is very easy to +define your own sorting function. + +=head2 Changing the BTREE sort order + +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 strict ; + use DB_File ; + + my %h ; + + sub Compare + { + my ($key1, $key2) = @_ ; + "\L$key1" cmp "\L$key2" ; + } + + # specify the Perl sub that will do the comparison + $DB_BTREE->{'compare'} = \&Compare ; + + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open file 'tree': $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + +Here is the output from the code above. + + mouse + Smith + Wall + +There are a few point to bear in mind if you want to change the +ordering in a BTREE database: + +=over 5 + +=item 1. + +The new compare function must be specified when you create the database. + +=item 2. + +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. + +=back + +=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 +the flags element of C<$DB_BTREE> to R_DUP when creating the database. + +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 strict ; + use DB_File ; + + use vars qw($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 + 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 associative array + # and print each key/value pair. + foreach (keys %h) + { print "$_ -> $h{$_}\n" } + + untie %h ; + +Here is the output: + + Smith -> John + Wall -> Larry + Wall -> Larry + Wall -> Larry + mouse -> mickey + +As you can see 3 records have been successfully created with key C<Wall> +- the only thing is, when they are retrieved from the database they +I<seem> to have the same value, namely C<Larry>. The problem is caused +by the way that the associative array interface works. Basically, when +the associative array interface is used to fetch the value associated +with a given key, it will only ever retrieve the first value. + +Although it may not be immediately obvious from the code above, the +associative array interface can be used to write values with duplicate +keys, but it cannot be used to read them back from the database. + +The way to get around this problem is to use the Berkeley DB API method +called C<seq>. This method allows sequential access to key/value +pairs. See L<THE API INTERFACE> for details of both the C<seq> method +and the API in general. + +Here is the script above rewritten using the C<seq> API method. + + 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 + 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 ; + for ($status = $x->seq($key, $value, R_FIRST) ; + $status == 0 ; + $status = $x->seq($key, $value, R_NEXT) ) + { print "$key -> $value\n" } + + undef $x ; + untie %h ; + +that prints: + + Smith -> John + Wall -> Brick + Wall -> Brick + Wall -> Larry + mouse -> mickey + +This time we have got all the key/value pairs, including the multiple +values associated with the key C<Wall>. + +=head2 The get_dup() Method + +B<DB_File> comes with a utility method, called C<get_dup>, to assist in +reading duplicate values from BTREE databases. The method can take the +following forms: + + $count = $x->get_dup($key) ; + @list = $x->get_dup($key) ; + %list = $x->get_dup($key, 1) ; + +In a scalar context the method returns the number of values associated +with the key, C<$key>. + +In list context, it returns all the values which match C<$key>. Note +that the values will be returned in an apparently random order. + +In list context, if the second parameter is present and evaluates +TRUE, the method returns an associative array. The keys of the +associative array correspond to the values that matched in the BTREE +and the values of the array are a count of the number of times that +particular value occurred in the BTREE. + +So assuming the database created above, we can use C<get_dup> like +this: + + my $cnt = $x->get_dup("Wall") ; + print "Wall occurred $cnt times\n" ; + + my %hash = $x->get_dup("Wall", 1) ; + print "Larry is there\n" if $hash{'Larry'} ; + print "There are $hash{'Brick'} Brick Walls\n" ; + + my @list = $x->get_dup("Wall") ; + print "Wall => [@list]\n" ; + + @list = $x->get_dup("Smith") ; + print "Smith => [@list]\n" ; + + @list = $x->get_dup("Dog") ; + 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 => [] + +=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 +is used along with the R_CURSOR flag. + + $x->seq($key, $value, R_CURSOR) ; + +Here is the relevant quote from the dbopen man page where it defines +the use of the R_CURSOR flag with seq: + + Note, for the DB_BTREE access method, the returned key is not + necessarily an exact match for the specified key. The returned key + is the smallest key greater than or equal to the specified key, + permitting partial key matches and range searches. + +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 strict ; + use DB_File ; + use Fcntl ; + + use vars qw($filename $x %h $st $key $value) ; + + sub match + { + my $key = shift ; + my $value = 0; + my $orig_key = $key ; + $x->seq($key, $value, R_CURSOR) ; + print "$orig_key\t-> $key\t-> $value\n" ; + } + + $filename = "tree" ; + unlink $filename ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $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" ; + match "A" ; + match "a" ; + + undef $x ; + untie %h ; + +Here is the output: + + IN ORDER + Smith -> John + Wall -> Larry + Walls -> Brick + mouse -> mickey + + PARTIAL MATCH + Wa -> Wall -> Larry + A -> Smith -> John + a -> mouse -> mickey + +=head1 DB_RECNO + +DB_RECNO provides an interface to flat text files. Both variable and +fixed length records are supported. + +In order to make RECNO more compatible with Perl the array offset for +all RECNO arrays begins at 0 rather than 1 as in Berkeley DB. + +As with normal Perl arrays, a RECNO array can be accessed using +negative indexes. The index -1 refers to the last element of the array, +-2 the second last, and so on. Attempting to access an element before +the start of the array will raise a fatal run-time error. + +=head2 The 'bval' Option + +The operation of the bval option warrants some discussion. Here is the +definition of bval from the Berkeley DB 1.85 recno manual page: + + The delimiting byte to be used to mark the end of a + record for variable-length records, and the pad charac- + ter for fixed-length records. If no value is speci- + fied, newlines (``\n'') are used to mark the end of + variable-length records and fixed-length records are + padded with spaces. + +The second sentence is wrong. In actual fact bval will only default to +C<"\n"> when the openinfo parameter in dbopen is NULL. If a non-NULL +openinfo parameter is used at all, the value that happens to be in bval +will be used. That means you always have to specify bval when making +use of any of the options in the openinfo parameter. This documentation +error will be fixed in the next release of Berkeley DB. + +That clarifies the situation with regards Berkeley DB itself. What +about B<DB_File>? Well, the behavior defined in the quote above is +quite useful, so B<DB_File> conforms it. + +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. + +=head2 A Simple Example + +Here is a simple example that uses RECNO. + + use strict ; + use DB_File ; + + my @h ; + tie @h, "DB_File", "text", O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file 'text': $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + # use a negative index + print "The last element is $h[-1]\n" ; + print "The 2nd last element is $h[-2]\n" ; + + untie @h ; + +Here is the output from the script: + + + Element 1 Exists with value blue + The last element is yellow + The 2nd last element is blue + +=head2 Extra Methods + +If you are using a version of Perl earlier than 5.004_57, the tied +array interface is quite limited. The example script above will work, +but you won't be able to use C<push>, C<pop>, C<shift>, C<unshift> +etc. with the tied array. + +To make the interface more useful for older versions of Perl, a number +of methods are supplied with B<DB_File> to simulate the missing array +operations. All these methods are accessed via the object returned from +the tie call. + +Here are the methods: + +=over 5 + +=item B<$X-E<gt>push(list) ;> + +Pushes the elements of C<list> to the end of the array. + +=item B<$value = $X-E<gt>pop ;> + +Removes and returns the last element of the array. + +=item B<$X-E<gt>shift> + +Removes and returns the first element of the array. + +=item B<$X-E<gt>unshift(list) ;> + +Pushes the elements of C<list> to the start of the array. + +=item B<$X-E<gt>length> + +Returns the number of elements in the array. + +=back + +=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 +L<THE API INTERFACE>). + + 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 + or die "Cannot open file $file: $!\n" ; + + # first create a text file to play with + $h[0] = "zero" ; + $h[1] = "one" ; + $h[2] = "two" ; + $h[3] = "three" ; + $h[4] = "four" ; + + + # Print the records in order. + # + # 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. + + print "\nORIGINAL\n" ; + foreach $i (0 .. $H->length - 1) { + print "$i: $h[$i]\n" ; + } + + # use the push & pop methods + $a = $H->pop ; + $H->push("last") ; + print "\nThe last record was [$a]\n" ; + + # and the shift & unshift methods + $a = $H->shift ; + $H->unshift("first") ; + print "The first record was [$a]\n" ; + + # Use the API to add a new record after record 2. + $i = 2 ; + $H->put($i, "Newbie", R_IAFTER) ; + + # and a new record before record 1. + $i = 1 ; + $H->put($i, "New One", R_IBEFORE) ; + + # delete record 3 + $H->del(3) ; + + # now print the records in reverse order + print "\nREVERSE\n" ; + for ($i = $H->length - 1 ; $i >= 0 ; -- $i) + { print "$i: $h[$i]\n" } + + # 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 ; + $s = $H->seq($k, $v, R_PREV)) + { print "$k: $v\n" } + + undef $H ; + untie @h ; + +and this is what it outputs: + + ORIGINAL + 0: zero + 1: one + 2: two + 3: three + 4: four + + The last record was [four] + The first record was [zero] + + REVERSE + 5: last + 4: three + 3: Newbie + 2: one + 1: New One + 0: first + + REVERSE again + 5: last + 4: three + 3: Newbie + 2: one + 1: New One + 0: first + +Notes: + +=over 5 + +=item 1. + +Rather than iterating through the array, C<@h> like this: + + foreach $i (@h) + +it is necessary to use either this: + + foreach $i (0 .. $H->length - 1) + +or this: + + for ($a = $H->get($k, $v, R_FIRST) ; + $a == 0 ; + $a = $H->get($k, $v, R_NEXT) ) + +=item 2. + +Notice that both times the C<put> method was used the record index was +specified using a variable, C<$i>, rather than the literal value +itself. This is because C<put> will return the record number of the +inserted line via that parameter. + +=back + +=head1 THE API INTERFACE + +As well as accessing Berkeley DB using a tied hash or array, it is also +possible to make direct use of most of the API functions defined in the +Berkeley DB documentation. + +To do this you need to store a copy of the object returned from the tie. + + $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) ; + +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. + + use DB_File ; + $db = tie %hash, "DB_File", "filename" + or die "Cannot tie filename: $!" ; + ... + undef $db ; + untie %hash ; + +See L<The untie() Gotcha> for more details. + +All the functions defined in L<dbopen> are available except for +close() and dbopen() itself. The B<DB_File> method interface to the +supported functions have been implemented to mirror the way Berkeley DB +works whenever possible. In particular note that: + +=over 5 + +=item * + +The methods return a status value. All return 0 on success. +All return -1 to signify an error and set C<$!> to the exact +error code. The return code 1 generally (but not always) means that the +key specified did not exist in the database. + +Other return codes are defined. See below and in the Berkeley DB +documentation for details. The Berkeley DB documentation should be used +as the definitive source. + +=item * + +Whenever a Berkeley DB function returns data via one of its parameters, +the equivalent B<DB_File> method does exactly the same. + +=item * + +If you are careful, it is possible to mix API calls with the tied +hash/array interface in the same piece of code. Although only a few of +the methods used to implement the tied interface currently make use of +the cursor, you should always assume that the cursor has been changed +any time the tied hash/array interface is used. As an example, this +code will probably not do what you expect: + + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; + + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; + + # this line will modify the cursor + $count = scalar keys %x ; + + # Get the second key/value pair. + # oops, it didn't, it got the last key/value pair! + $X->seq($key, $value, R_NEXT) ; + +The code above can be rearranged to get around the problem, like this: + + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; + + # this line will modify the cursor + $count = scalar keys %x ; + + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; + + # Get the second key/value pair. + # worked this time. + $X->seq($key, $value, R_NEXT) ; + +=back + +All the constants defined in L<dbopen> for use in the flags parameters +in the methods defined below are also available. Refer to the Berkeley +DB documentation for the precise meaning of the flags values. + +Below is a list of the methods available. + +=over 5 + +=item B<$status = $X-E<gt>get($key, $value [, $flags]) ;> + +Given a key (C<$key>) this method reads the value associated with it +from the database. The value read from the database is returned in the +C<$value> parameter. + +If the key does not exist the method returns 1. + +No flags are currently defined for this method. + +=item B<$status = $X-E<gt>put($key, $value [, $flags]) ;> + +Stores the key/value pair in the database. + +If you use either the R_IAFTER or R_IBEFORE flags, the C<$key> parameter +will have the record number of the inserted key/value pair set. + +Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and +R_SETCURSOR. + +=item B<$status = $X-E<gt>del($key [, $flags]) ;> + +Removes all key/value pairs with key C<$key> from the database. + +A return code of 1 means that the requested key was not in the +database. + +R_CURSOR is the only valid flag at present. + +=item B<$status = $X-E<gt>fd ;> + +Returns the file descriptor for the underlying database. + +See L<Locking Databases> for an example of how to make use of the +C<fd> method to lock your database. + +=item B<$status = $X-E<gt>seq($key, $value, $flags) ;> + +This interface allows sequential retrieval from the database. See +L<dbopen> for full details. + +Both the C<$key> and C<$value> parameters will be set to the key/value +pair read from the database. + +The flags parameter is mandatory. The valid flag values are R_CURSOR, +R_FIRST, R_LAST, R_NEXT and R_PREV. + +=item B<$status = $X-E<gt>sync([$flags]) ;> + +Flushes any cached buffers to disk. + +R_RECNOSYNC is the only valid flag at present. + +=back + +=head1 HINTS AND TIPS + + +=head2 Locking Databases + +Concurrent access of a read-write database by several parties requires +them all to use some kind of locking. Here's an example of Tom's that +uses the I<fd> method to get the file descriptor, and then a careful +open() to give something Perl will flock() for you. Run this repeatedly +in the background to watch the locks granted in proper order. + + use DB_File; + + use strict; + + sub LOCK_SH { 1 } + sub LOCK_EX { 2 } + sub LOCK_NB { 4 } + sub LOCK_UN { 8 } + + my($oldval, $fd, $db, %db, $value, $key); + + $key = shift || 'default'; + $value = shift || 'magic'; + + $value .= " $$"; + + $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644) + || die "dbcreat /tmp/foo.db $!"; + $fd = $db->fd; + print "$$: db fd is $fd\n"; + open(DB_FH, "+<&=$fd") || die "dup $!"; + + + unless (flock (DB_FH, LOCK_SH | LOCK_NB)) { + print "$$: CONTENTION; can't read during write update! + Waiting for read lock ($!) ...."; + unless (flock (DB_FH, LOCK_SH)) { die "flock: $!" } + } + print "$$: Read lock granted\n"; + + $oldval = $db{$key}; + print "$$: Old value was $oldval\n"; + flock(DB_FH, LOCK_UN); + + unless (flock (DB_FH, LOCK_EX | LOCK_NB)) { + print "$$: CONTENTION; must have exclusive lock! + Waiting for write lock ($!) ...."; + unless (flock (DB_FH, LOCK_EX)) { die "flock: $!" } + } + + print "$$: Write lock granted\n"; + $db{$key} = $value; + $db->sync; # to flush + sleep 10; + + flock(DB_FH, LOCK_UN); + undef $db; + untie %db; + close(DB_FH); + print "$$: Updated db to $key=$value\n"; + +=head2 Sharing Databases With C Applications + +There is no technical reason why a Berkeley DB database cannot be +shared by both a Perl and a C application. + +The vast majority of problems that are reported in this area boil down +to the fact that C strings are NULL terminated, whilst Perl strings are +not. + +Here is a real example. Netscape 2.0 keeps a record of the locations you +visit along with the time you last visited them in a DB_HASH database. +This is usually stored in the file F<~/.netscape/history.db>. The key +field in the database is the location string and the value field is the +time the location was last visited stored as a 4 byte binary value. + +If you haven't already guessed, the location string is stored with a +terminating NULL. This means you need to be careful when accessing the +database. + +Here is a snippet of code that is loosely based on Tom Christiansen's +I<ggh> script (available from your nearest CPAN archive in +F<authors/id/TOMC/scripts/nshist.gz>). + + use strict ; + use DB_File ; + use Fcntl ; + + use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ; + $dotdir = $ENV{HOME} || $ENV{LOGNAME}; + + $HISTORY = "$dotdir/.netscape/history.db"; + + tie %hist_db, 'DB_File', $HISTORY + or die "Cannot open $HISTORY: $!\n" ;; + + # Dump the complete database + while ( ($href, $binary_time) = each %hist_db ) { + + # remove the terminating NULL + $href =~ s/\x00$// ; + + # convert the binary time into a user friendly string + $date = localtime unpack("V", $binary_time); + print "$date $href\n" ; + } + + # check for the existence of a specific key + # remember to add the NULL + if ( $binary_time = $hist_db{"http://mox.perl.com/\x00"} ) { + $date = localtime unpack("V", $binary_time) ; + print "Last visited mox.perl.com on $date\n" ; + } + else { + print "Never visited mox.perl.com\n" + } + + untie %hist_db ; + +=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>. + +Even if you don't currently make use of the API interface, it is still +worth reading it. + +Here is an example which illustrates the problem from a B<DB_File> +perspective: + + use DB_File ; + use Fcntl ; + + my %x ; + my $X ; + + $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_TRUNC + or die "Cannot tie first time: $!" ; + + $x{123} = 456 ; + + untie %x ; + + tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT + or die "Cannot tie second time: $!" ; + + untie %x ; + +When run, the script will produce this error message: + + Cannot tie second time: Invalid argument at bad.file line 14. + +Although the error message above refers to the second tie() statement +in the script, the source of the problem is really with the untie() +statement that precedes it. + +Having read L<perltie> you will probably have already guessed that the +error is caused by the extra copy of the tied object stored in C<$X>. +If you haven't, then the problem boils down to the fact that the +B<DB_File> destructor, DESTROY, will not be called until I<all> +references to the tied object are destroyed. Both the tied variable, +C<%x>, and C<$X> above hold a reference to the object. The call to +untie() will destroy the first, but C<$X> still holds a valid +reference, so the destructor will not get called and the database file +F<tst.fil> will remain open. The fact that Berkeley DB then reports the +attempt to open a database that is alreday open via the catch-all +"Invalid argument" doesn't help. + +If you run the script with the C<-w> flag the error message becomes: + + untie attempted while 1 inner references still exist at bad.file line 12. + Cannot tie second time: Invalid argument at bad.file line 14. + +which pinpoints the real problem. Finally the script can now be +modified to fix the original problem by destroying the API object +before the untie: + + ... + $x{123} = 456 ; + + undef $X ; + untie %x ; + + $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT + ... + + +=head1 COMMON QUESTIONS + +=head2 Why is there Perl source in my database? + +If you look at the contents of a database file created by DB_File, +there can sometimes be part of a Perl script included in it. + +This happens because Berkeley DB uses dynamic memory to allocate +buffers which will subsequently be written to the database file. Being +dynamic, the memory could have been used for anything before DB +malloced it. As Berkeley DB doesn't clear the memory once it has been +allocated, the unused portions will contain random junk. In the case +where a Perl script gets written to the database, the random junk will +correspond to an area of dynamic memory that happened to be used during +the compilation of the script. + +Unless you don't like the possibility of there being part of your Perl +scripts embedded in a database file, this is nothing to worry about. + +=head2 How do I store complex data structures with DB_File? + +Although B<DB_File> cannot do this directly, there is a module which +can layer transparently over B<DB_File> to accomplish this feat. + +Check out the MLDBM module, available on CPAN in the directory +F<modules/by-module/MLDBM>. + +=head2 What does "Invalid Argument" mean? + +You will get this error message when one of the parameters in the +C<tie> call is wrong. Unfortunately there are quite a few parameters to +get wrong, so it can be difficult to figure out which one it is. + +Here are a couple of possibilities: + +=over 5 + +=item 1. + +Attempting to reopen a database without closing it. + +=item 2. + +Using the O_WRONLY flag. + +=back + +=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. +Consider this script: + + use strict ; + use DB_File ; + use vars qw(%x) ; + tie %x, DB_File, "filename" ; + +Running it produces the error in question: + + 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: + + tie %x, "DB_File", "filename" ; + +Although it might seem like a real pain, it is really worth the effort +of having a C<use strict> in all your scripts. + +=head1 HISTORY + +Moved to the Changes file. + +=head1 BUGS + +Some older versions of Berkeley DB had problems with fixed length +records using the RECNO file format. This problem has been fixed since +version 1.85 of Berkeley DB. + +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 AVAILABILITY + +B<DB_File> comes with the standard Perl source distribution. Look in +the directory F<ext/DB_File>. Given the amount of time between releases +of Perl the version that ships with Perl is quite likely to be out of +date, so the most recent version can always be found on CPAN (see +L<perlmod/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 or 2.x of +Berkeley DB, but is limited to the functionality provided by version 1. + +The official web site for Berkeley DB is +F<http://www.sleepycat.com/db>. The ftp equivalent is +F<ftp.sleepycat.com:/pub>. Both versions 1 and 2 of Berkeley DB are +available there. + +Alternatively, Berkeley DB version 1 is available at your nearest CPAN +archive in F<src/misc/db.1.85.tar.gz>. + +If you are running IRIX, then get Berkeley DB version 1 from +F<http://reality.sgi.com/ariel>. It has the patches necessary to +compile properly on IRIX 5.3. + +=head1 COPYRIGHT + +Copyright (c) 1995-8 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. + +Although B<DB_File> is covered by the Perl license, the library it +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 +http://www.sleepycat.com) regarding the license: + + 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 + software is Perl, and not your scripts. Any Perl scripts that you + write are your property, including scripts that make use of + Berkeley DB. Neither the Perl license nor the Berkeley DB license + place any restriction on what you may do with them. + +If you are in any doubt about the license situation, contact either the +Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details. + + +=head1 SEE ALSO + +L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)> + +=head1 AUTHOR + +The DB_File interface was written by Paul Marquess +E<lt>pmarquess@bfsec.bt.co.ukE<gt>. +Questions about the DB system itself may be addressed to +E<lt>db@sleepycat.com<gt>. + +=cut diff --git a/contrib/perl5/ext/DB_File/DB_File.xs b/contrib/perl5/ext/DB_File/DB_File.xs new file mode 100644 index 0000000..c661023 --- /dev/null +++ b/contrib/perl5/ext/DB_File/DB_File.xs @@ -0,0 +1,1497 @@ +/* + + DB_File.xs -- Perl 5 interface to Berkeley DB + + written by Paul Marquess (pmarquess@bfsec.bt.co.uk) + last modified 16th May 1998 + version 1.60 + + All comments/suggestions/problems are welcome + + Copyright (c) 1995, 1996, 1997, 1998 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. + + Changes: + 0.1 - Initial Release + 0.2 - No longer bombs out if dbopen returns an error. + 0.3 - Added some support for multiple btree compares + 1.0 - Complete support for multiple callbacks added. + Fixed a problem with pushing a value onto an empty list. + 1.01 - Fixed a SunOS core dump problem. + The return value from TIEHASH wasn't set to NULL when + dbopen returned an error. + 1.02 - Use ALIAS to define TIEARRAY. + Removed some redundant commented code. + Merged OS2 code into the main distribution. + Allow negative subscripts with RECNO interface. + Changed the default flags to O_CREAT|O_RDWR + 1.03 - Added EXISTS + 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by + Dave Hammen, hammen@gothamcity.jsc.nasa.gov + 1.05 - Added logic to allow prefix & hash types to be specified via + Makefile.PL + 1.06 - Minor namespace cleanup: Localized PrintBtree. + 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n". + 1.08 - No change to DB_File.xs + 1.09 - Default mode for dbopen changed to 0666 + 1.10 - Fixed fd method so that it still returns -1 for + in-memory files when db 1.86 is used. + 1.11 - No change to DB_File.xs + 1.12 - No change to DB_File.xs + 1.13 - Tidied up a few casts. + 1.14 - Made it illegal to tie an associative array to a RECNO + database and an ordinary array to a HASH or BTREE database. + 1.50 - Make work with both DB 1.x or DB 2.x + 1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent + 1.52 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of + undefined value" warning with db_get and db_seq. + 1.53 - Added DB_RENUMBER to flags for recno. + 1.54 - Fixed bug in the fd method + 1.55 - Fix for AIX from Jarkko Hietaniemi + 1.56 - No change to DB_File.xs + 1.57 - added the #undef op to allow building with Threads support. + 1.58 - Fixed a problem with the use of sv_setpvn. When the + size is specified as 0, it does a strlen on the data. + This was ok for DB 1.x, but isn't for DB 2.x. + 1.59 - No change to DB_File.xs + 1.60 - Some code tidy up + + + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be + * shortly #included by the <db.h>) __attribute__ to the possibly + * already defined __attribute__, for example by GNUC or by Perl. */ + +#undef __attribute__ + +/* If Perl has been compiled with Threads support,the symbol op will + be defined here. This clashes with a field name in db.h, so get rid of it. + */ +#ifdef op +#undef op +#endif +#include <db.h> + +#include <fcntl.h> + +/* #define TRACE */ + + + +#ifdef DB_VERSION_MAJOR + +/* map version 2 features & constants onto their version 1 equivalent */ + +#ifdef DB_Prefix_t +#undef DB_Prefix_t +#endif +#define DB_Prefix_t size_t + +#ifdef DB_Hash_t +#undef DB_Hash_t +#endif +#define DB_Hash_t u_int32_t + +/* DBTYPE stays the same */ +/* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */ +typedef DB_INFO INFO ; + +/* version 2 has db_recno_t in place of recno_t */ +typedef db_recno_t recno_t; + + +#define R_CURSOR DB_SET_RANGE +#define R_FIRST DB_FIRST +#define R_IAFTER DB_AFTER +#define R_IBEFORE DB_BEFORE +#define R_LAST DB_LAST +#define R_NEXT DB_NEXT +#define R_NOOVERWRITE DB_NOOVERWRITE +#define R_PREV DB_PREV +#define R_SETCURSOR 0 +#define R_RECNOSYNC 0 +#define R_FIXEDLEN DB_FIXEDLEN +#define R_DUP DB_DUP + +#define db_HA_hash h_hash +#define db_HA_ffactor h_ffactor +#define db_HA_nelem h_nelem +#define db_HA_bsize db_pagesize +#define db_HA_cachesize db_cachesize +#define db_HA_lorder db_lorder + +#define db_BT_compare bt_compare +#define db_BT_prefix bt_prefix +#define db_BT_flags flags +#define db_BT_psize db_pagesize +#define db_BT_cachesize db_cachesize +#define db_BT_lorder db_lorder +#define db_BT_maxkeypage +#define db_BT_minkeypage + + +#define db_RE_reclen re_len +#define db_RE_flags flags +#define db_RE_bval re_pad +#define db_RE_bfname re_source +#define db_RE_psize db_pagesize +#define db_RE_cachesize db_cachesize +#define db_RE_lorder db_lorder + +#define TXN NULL, + +#define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag) + + +#define DBT_flags(x) x.flags = 0 +#define DB_flags(x, v) x |= v + +#else /* db version 1.x */ + +typedef union INFO { + HASHINFO hash ; + RECNOINFO recno ; + BTREEINFO btree ; + } INFO ; + + +#ifdef mDB_Prefix_t +#ifdef DB_Prefix_t +#undef DB_Prefix_t +#endif +#define DB_Prefix_t mDB_Prefix_t +#endif + +#ifdef mDB_Hash_t +#ifdef DB_Hash_t +#undef DB_Hash_t +#endif +#define DB_Hash_t mDB_Hash_t +#endif + +#define db_HA_hash hash.hash +#define db_HA_ffactor hash.ffactor +#define db_HA_nelem hash.nelem +#define db_HA_bsize hash.bsize +#define db_HA_cachesize hash.cachesize +#define db_HA_lorder hash.lorder + +#define db_BT_compare btree.compare +#define db_BT_prefix btree.prefix +#define db_BT_flags btree.flags +#define db_BT_psize btree.psize +#define db_BT_cachesize btree.cachesize +#define db_BT_lorder btree.lorder +#define db_BT_maxkeypage btree.maxkeypage +#define db_BT_minkeypage btree.minkeypage + +#define db_RE_reclen recno.reclen +#define db_RE_flags recno.flags +#define db_RE_bval recno.bval +#define db_RE_bfname recno.bfname +#define db_RE_psize recno.psize +#define db_RE_cachesize recno.cachesize +#define db_RE_lorder recno.lorder + +#define TXN + +#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag) +#define DBT_flags(x) +#define DB_flags(x, v) + +#endif /* db version 1 */ + + + +#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, flags) +#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, flags) +#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) + +#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags) +#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) +#ifdef DB_VERSION_MAJOR +#define db_DESTROY(db) ((db->dbp)->close)(db->dbp, 0) +#define db_close(db) ((db->dbp)->close)(db->dbp, 0) +#define db_del(db, key, flags) ((flags & R_CURSOR) \ + ? ((db->cursor)->c_del)(db->cursor, 0) \ + : ((db->dbp)->del)(db->dbp, NULL, &key, flags) ) + +#else + +#define db_DESTROY(db) ((db->dbp)->close)(db->dbp) +#define db_close(db) ((db->dbp)->close)(db->dbp) +#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) +#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) + +#endif + +#define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags) + +typedef struct { + DBTYPE type ; + DB * dbp ; + SV * compare ; + SV * prefix ; + SV * hash ; + int in_memory ; + INFO info ; +#ifdef DB_VERSION_MAJOR + DBC * cursor ; +#endif + } DB_File_type; + +typedef DB_File_type * DB_File ; +typedef DBT DBTKEY ; + +#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s) + +#define OutputValue(arg, name) \ + { if (RETVAL == 0) { \ + my_sv_setpvn(arg, name.data, name.size) ; \ + } \ + } + +#define OutputKey(arg, name) \ + { if (RETVAL == 0) \ + { \ + if (db->type != DB_RECNO) { \ + my_sv_setpvn(arg, name.data, name.size); \ + } \ + else \ + sv_setiv(arg, (I32)*(I32*)name.data - 1); \ + } \ + } + + +/* Internal Global Data */ +static recno_t Value ; +static recno_t zero = 0 ; +static DB_File CurrentDB ; +static DBTKEY empty ; + +#ifdef DB_VERSION_MAJOR + +static int +db_put(db, key, value, flags) +DB_File db ; +DBTKEY key ; +DBT value ; +u_int flags ; + +{ + int status ; + + if (flags & R_CURSOR) { + status = ((db->cursor)->c_del)(db->cursor, 0); + if (status != 0) + return status ; + + flags &= ~R_CURSOR ; + } + + return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ; + +} + +#endif /* DB_VERSION_MAJOR */ + +static void +GetVersionInfo() +{ + SV * ver_sv = perl_get_sv("DB_File::db_version", TRUE) ; +#ifdef DB_VERSION_MAJOR + int Major, Minor, Patch ; + + (void)db_version(&Major, &Minor, &Patch) ; + + /* check that libdb is recent enough */ + if (Major == 2 && Minor == 0 && Patch < 5) + croak("DB_File needs Berkeley DB 2.0.5 or greater, you have %d.%d.%d\n", + Major, Minor, Patch) ; + +#if PATCHLEVEL > 3 + sv_setpvf(ver_sv, "%d.%d", Major, Minor) ; +#else + { + char buffer[40] ; + sprintf(buffer, "%d.%d", Major, Minor) ; + sv_setpv(ver_sv, buffer) ; + } +#endif + +#else + sv_setiv(ver_sv, 1) ; +#endif + +} + + +static int +btree_compare(key1, key2) +const DBT * key1 ; +const DBT * key2 ; +{ + dSP ; + void * data1, * data2 ; + int retval ; + int count ; + + data1 = key1->data ; + data2 = key2->data ; + + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpv(data1,key1->size))); + PUSHs(sv_2mortal(newSVpv(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->compare, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + return (retval) ; + +} + +static DB_Prefix_t +btree_prefix(key1, key2) +const DBT * key1 ; +const DBT * key2 ; +{ + dSP ; + void * data1, * data2 ; + int retval ; + int count ; + + data1 = key1->data ; + data2 = key2->data ; + + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpv(data1,key1->size))); + PUSHs(sv_2mortal(newSVpv(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->prefix, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; +} + +static DB_Hash_t +hash_cb(data, size) +const void * data ; +size_t size ; +{ + dSP ; + int retval ; + int count ; + + if (size == 0) + data = "" ; + + /* DGH - Next two lines added to fix corrupted stack problem */ + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + + XPUSHs(sv_2mortal(newSVpv((char*)data,size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->hash, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; +} + + +#ifdef TRACE + +static void +PrintHash(hash) +INFO * hash ; +{ + printf ("HASH Info\n") ; + printf (" hash = %s\n", + (hash->db_HA_hash != NULL ? "redefined" : "default")) ; + printf (" bsize = %d\n", hash->db_HA_bsize) ; + printf (" ffactor = %d\n", hash->db_HA_ffactor) ; + printf (" nelem = %d\n", hash->db_HA_nelem) ; + printf (" cachesize = %d\n", hash->db_HA_cachesize) ; + printf (" lorder = %d\n", hash->db_HA_lorder) ; + +} + +static void +PrintRecno(recno) +INFO * recno ; +{ + printf ("RECNO Info\n") ; + printf (" flags = %d\n", recno->db_RE_flags) ; + printf (" cachesize = %d\n", recno->db_RE_cachesize) ; + printf (" psize = %d\n", recno->db_RE_psize) ; + printf (" lorder = %d\n", recno->db_RE_lorder) ; + printf (" reclen = %ul\n", (unsigned long)recno->db_RE_reclen) ; + printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ; + printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ; +} + +static void +PrintBtree(btree) +INFO * btree ; +{ + printf ("BTREE Info\n") ; + printf (" compare = %s\n", + (btree->db_BT_compare ? "redefined" : "default")) ; + printf (" prefix = %s\n", + (btree->db_BT_prefix ? "redefined" : "default")) ; + printf (" flags = %d\n", btree->db_BT_flags) ; + printf (" cachesize = %d\n", btree->db_BT_cachesize) ; + printf (" psize = %d\n", btree->db_BT_psize) ; +#ifndef DB_VERSION_MAJOR + printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ; + printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ; +#endif + printf (" lorder = %d\n", btree->db_BT_lorder) ; +} + +#else + +#define PrintRecno(recno) +#define PrintHash(hash) +#define PrintBtree(btree) + +#endif /* TRACE */ + + +static I32 +GetArrayLength(db) +DB_File db ; +{ + DBT key ; + DBT value ; + int RETVAL ; + + DBT_flags(key) ; + DBT_flags(value) ; + RETVAL = do_SEQ(db, key, value, R_LAST) ; + if (RETVAL == 0) + RETVAL = *(I32 *)key.data ; + else /* No key means empty file */ + RETVAL = 0 ; + + return ((I32)RETVAL) ; +} + +static recno_t +GetRecnoKey(db, value) +DB_File db ; +I32 value ; +{ + if (value < 0) { + /* Get the length of the array */ + I32 length = GetArrayLength(db) ; + + /* check for attempt to write before start of array */ + if (length + value + 1 <= 0) + croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; + + value = length + value + 1 ; + } + else + ++ value ; + + return value ; +} + +static DB_File +ParseOpenInfo(isHASH, name, flags, mode, sv) +int isHASH ; +char * name ; +int flags ; +int mode ; +SV * sv ; +{ + SV ** svp; + HV * action ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + void * openinfo = NULL ; + INFO * info = &RETVAL->info ; + +/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ + Zero(RETVAL, 1, DB_File_type) ; + + /* Default to HASH */ + RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; + RETVAL->type = DB_HASH ; + + /* DGH - Next line added to avoid SEGV on existing hash DB */ + CurrentDB = RETVAL; + + /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ + RETVAL->in_memory = (name == NULL) ; + + if (sv) + { + if (! SvROK(sv) ) + croak ("type parameter is not a reference") ; + + svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; + if (svp && SvOK(*svp)) + action = (HV*) SvRV(*svp) ; + else + croak("internal error") ; + + if (sv_isa(sv, "DB_File::HASHINFO")) + { + + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_HASH database") ; + + RETVAL->type = DB_HASH ; + openinfo = (void*)info ; + + svp = hv_fetch(action, "hash", 4, FALSE); + + if (svp && SvOK(*svp)) + { + info->db_HA_hash = hash_cb ; + RETVAL->hash = newSVsv(*svp) ; + } + else + info->db_HA_hash = NULL ; + + svp = hv_fetch(action, "ffactor", 7, FALSE); + info->db_HA_ffactor = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "nelem", 5, FALSE); + info->db_HA_nelem = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "bsize", 5, FALSE); + info->db_HA_bsize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_HA_cachesize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_HA_lorder = svp ? SvIV(*svp) : 0; + + PrintHash(info) ; + } + else if (sv_isa(sv, "DB_File::BTREEINFO")) + { + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_BTREE database"); + + RETVAL->type = DB_BTREE ; + openinfo = (void*)info ; + + svp = hv_fetch(action, "compare", 7, FALSE); + if (svp && SvOK(*svp)) + { + info->db_BT_compare = btree_compare ; + RETVAL->compare = newSVsv(*svp) ; + } + else + info->db_BT_compare = NULL ; + + svp = hv_fetch(action, "prefix", 6, FALSE); + if (svp && SvOK(*svp)) + { + info->db_BT_prefix = btree_prefix ; + RETVAL->prefix = newSVsv(*svp) ; + } + else + info->db_BT_prefix = NULL ; + + svp = hv_fetch(action, "flags", 5, FALSE); + info->db_BT_flags = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_BT_cachesize = svp ? SvIV(*svp) : 0; + +#ifndef DB_VERSION_MAJOR + svp = hv_fetch(action, "minkeypage", 10, FALSE); + info->btree.minkeypage = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "maxkeypage", 10, FALSE); + info->btree.maxkeypage = svp ? SvIV(*svp) : 0; +#endif + + svp = hv_fetch(action, "psize", 5, FALSE); + info->db_BT_psize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_BT_lorder = svp ? SvIV(*svp) : 0; + + PrintBtree(info) ; + + } + else if (sv_isa(sv, "DB_File::RECNOINFO")) + { + if (isHASH) + croak("DB_File can only tie an array to a DB_RECNO database"); + + RETVAL->type = DB_RECNO ; + openinfo = (void *)info ; + + info->db_RE_flags = 0 ; + + svp = hv_fetch(action, "flags", 5, FALSE); + info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "reclen", 6, FALSE); + info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "psize", 5, FALSE); + info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0); + +#ifdef DB_VERSION_MAJOR + info->re_source = name ; + name = NULL ; +#endif + svp = hv_fetch(action, "bfname", 6, FALSE); + if (svp && SvOK(*svp)) { + char * ptr = SvPV(*svp,PL_na) ; +#ifdef DB_VERSION_MAJOR + name = (char*) PL_na ? ptr : NULL ; +#else + info->db_RE_bfname = (char*) (PL_na ? ptr : NULL) ; +#endif + } + else +#ifdef DB_VERSION_MAJOR + name = NULL ; +#else + info->db_RE_bfname = NULL ; +#endif + + svp = hv_fetch(action, "bval", 4, FALSE); +#ifdef DB_VERSION_MAJOR + if (svp && SvOK(*svp)) + { + int value ; + if (SvPOK(*svp)) + value = (int)*SvPV(*svp, PL_na) ; + else + value = SvIV(*svp) ; + + if (info->flags & DB_FIXEDLEN) { + info->re_pad = value ; + info->flags |= DB_PAD ; + } + else { + info->re_delim = value ; + info->flags |= DB_DELIMITER ; + } + + } +#else + if (svp && SvOK(*svp)) + { + if (SvPOK(*svp)) + info->db_RE_bval = (u_char)*SvPV(*svp, PL_na) ; + else + info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ; + DB_flags(info->flags, DB_DELIMITER) ; + + } + else + { + if (info->db_RE_flags & R_FIXEDLEN) + info->db_RE_bval = (u_char) ' ' ; + else + info->db_RE_bval = (u_char) '\n' ; + DB_flags(info->flags, DB_DELIMITER) ; + } +#endif + +#ifdef DB_RENUMBER + info->flags |= DB_RENUMBER ; +#endif + + PrintRecno(info) ; + } + else + croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + } + + + /* OS2 Specific Code */ +#ifdef OS2 +#ifdef __EMX__ + flags |= O_BINARY; +#endif /* __EMX__ */ +#endif /* OS2 */ + +#ifdef DB_VERSION_MAJOR + + { + int Flags = 0 ; + int status ; + + /* Map 1.x flags to 2.x flags */ + if ((flags & O_CREAT) == O_CREAT) + Flags |= DB_CREATE ; + +#ifdef O_NONBLOCK + if ((flags & O_NONBLOCK) == O_NONBLOCK) + Flags |= DB_EXCL ; +#endif + +#if O_RDONLY == 0 + if (flags == O_RDONLY) +#else + if (flags & O_RDONLY) == O_RDONLY) +#endif + Flags |= DB_RDONLY ; + +#ifdef O_NONBLOCK + if ((flags & O_TRUNC) == O_TRUNC) + Flags |= DB_TRUNCATE ; +#endif + + status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ; + if (status == 0) + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ; + + if (status) + RETVAL->dbp = NULL ; + + } +#else + RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; +#endif + + return (RETVAL) ; +} + + +static int +not_here(s) +char *s; +{ + croak("DB_File::%s not implemented on this architecture", s); + return -1; +} + +static double +constant(name, arg) +char *name; +int arg; +{ + errno = 0; + switch (*name) { + case 'A': + break; + case 'B': + if (strEQ(name, "BTREEMAGIC")) +#ifdef BTREEMAGIC + return BTREEMAGIC; +#else + goto not_there; +#endif + if (strEQ(name, "BTREEVERSION")) +#ifdef BTREEVERSION + return BTREEVERSION; +#else + goto not_there; +#endif + break; + case 'C': + break; + case 'D': + if (strEQ(name, "DB_LOCK")) +#ifdef DB_LOCK + return DB_LOCK; +#else + goto not_there; +#endif + if (strEQ(name, "DB_SHMEM")) +#ifdef DB_SHMEM + return DB_SHMEM; +#else + goto not_there; +#endif + if (strEQ(name, "DB_TXN")) +#ifdef DB_TXN + return (U32)DB_TXN; +#else + goto not_there; +#endif + break; + case 'E': + break; + case 'F': + break; + case 'G': + break; + case 'H': + if (strEQ(name, "HASHMAGIC")) +#ifdef HASHMAGIC + return HASHMAGIC; +#else + goto not_there; +#endif + if (strEQ(name, "HASHVERSION")) +#ifdef HASHVERSION + return HASHVERSION; +#else + goto not_there; +#endif + break; + case 'I': + break; + case 'J': + break; + case 'K': + break; + case 'L': + break; + case 'M': + if (strEQ(name, "MAX_PAGE_NUMBER")) +#ifdef MAX_PAGE_NUMBER + return (U32)MAX_PAGE_NUMBER; +#else + goto not_there; +#endif + if (strEQ(name, "MAX_PAGE_OFFSET")) +#ifdef MAX_PAGE_OFFSET + return MAX_PAGE_OFFSET; +#else + goto not_there; +#endif + if (strEQ(name, "MAX_REC_NUMBER")) +#ifdef MAX_REC_NUMBER + return (U32)MAX_REC_NUMBER; +#else + goto not_there; +#endif + break; + case 'N': + break; + case 'O': + break; + case 'P': + break; + case 'Q': + break; + case 'R': + if (strEQ(name, "RET_ERROR")) +#ifdef RET_ERROR + return RET_ERROR; +#else + goto not_there; +#endif + if (strEQ(name, "RET_SPECIAL")) +#ifdef RET_SPECIAL + return RET_SPECIAL; +#else + goto not_there; +#endif + if (strEQ(name, "RET_SUCCESS")) +#ifdef RET_SUCCESS + return RET_SUCCESS; +#else + goto not_there; +#endif + if (strEQ(name, "R_CURSOR")) +#ifdef R_CURSOR + return R_CURSOR; +#else + goto not_there; +#endif + if (strEQ(name, "R_DUP")) +#ifdef R_DUP + return R_DUP; +#else + goto not_there; +#endif + if (strEQ(name, "R_FIRST")) +#ifdef R_FIRST + return R_FIRST; +#else + goto not_there; +#endif + if (strEQ(name, "R_FIXEDLEN")) +#ifdef R_FIXEDLEN + return R_FIXEDLEN; +#else + goto not_there; +#endif + if (strEQ(name, "R_IAFTER")) +#ifdef R_IAFTER + return R_IAFTER; +#else + goto not_there; +#endif + if (strEQ(name, "R_IBEFORE")) +#ifdef R_IBEFORE + return R_IBEFORE; +#else + goto not_there; +#endif + if (strEQ(name, "R_LAST")) +#ifdef R_LAST + return R_LAST; +#else + goto not_there; +#endif + if (strEQ(name, "R_NEXT")) +#ifdef R_NEXT + return R_NEXT; +#else + goto not_there; +#endif + if (strEQ(name, "R_NOKEY")) +#ifdef R_NOKEY + return R_NOKEY; +#else + goto not_there; +#endif + if (strEQ(name, "R_NOOVERWRITE")) +#ifdef R_NOOVERWRITE + return R_NOOVERWRITE; +#else + goto not_there; +#endif + if (strEQ(name, "R_PREV")) +#ifdef R_PREV + return R_PREV; +#else + goto not_there; +#endif + if (strEQ(name, "R_RECNOSYNC")) +#ifdef R_RECNOSYNC + return R_RECNOSYNC; +#else + goto not_there; +#endif + if (strEQ(name, "R_SETCURSOR")) +#ifdef R_SETCURSOR + return R_SETCURSOR; +#else + goto not_there; +#endif + if (strEQ(name, "R_SNAPSHOT")) +#ifdef R_SNAPSHOT + return R_SNAPSHOT; +#else + goto not_there; +#endif + break; + case 'S': + break; + case 'T': + break; + case 'U': + break; + case 'V': + break; + case 'W': + break; + case 'X': + break; + case 'Y': + break; + case 'Z': + break; + case '_': + break; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +MODULE = DB_File PACKAGE = DB_File PREFIX = db_ + +BOOT: + { + GetVersionInfo() ; + + empty.data = &zero ; + empty.size = sizeof(recno_t) ; + DBT_flags(empty) ; + } + +double +constant(name,arg) + char * name + int arg + + +DB_File +db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH) + int isHASH + char * dbtype + int flags + int mode + CODE: + { + char * name = (char *) NULL ; + SV * sv = (SV *) NULL ; + + if (items >= 3 && SvOK(ST(2))) + name = (char*) SvPV(ST(2), PL_na) ; + + if (items == 6) + sv = ST(5) ; + + RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ; + if (RETVAL->dbp == NULL) + RETVAL = NULL ; + } + OUTPUT: + RETVAL + +int +db_DESTROY(db) + DB_File db + INIT: + CurrentDB = db ; + CLEANUP: + if (db->hash) + SvREFCNT_dec(db->hash) ; + if (db->compare) + SvREFCNT_dec(db->compare) ; + if (db->prefix) + SvREFCNT_dec(db->prefix) ; + Safefree(db) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; +#endif + + +int +db_DELETE(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + INIT: + CurrentDB = db ; + + +int +db_EXISTS(db, key) + DB_File db + DBTKEY key + CODE: + { + DBT value ; + + DBT_flags(value) ; + CurrentDB = db ; + RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ; + } + OUTPUT: + RETVAL + +int +db_FETCH(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + CODE: + { + DBT value ; + + DBT_flags(value) ; + CurrentDB = db ; + /* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */ + RETVAL = db_get(db, key, value, flags) ; + ST(0) = sv_newmortal(); + OutputValue(ST(0), value) + } + +int +db_STORE(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + INIT: + CurrentDB = db ; + + +int +db_FIRSTKEY(db) + DB_File db + CODE: + { + DBTKEY key ; + DBT value ; + DB * Db = db->dbp ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; + RETVAL = do_SEQ(db, key, value, R_FIRST) ; + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) ; + } + +int +db_NEXTKEY(db, key) + DB_File db + DBTKEY key + CODE: + { + DBT value ; + DB * Db = db->dbp ; + + DBT_flags(value) ; + CurrentDB = db ; + RETVAL = do_SEQ(db, key, value, R_NEXT) ; + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) ; + } + +# +# These would be nice for RECNO +# + +int +unshift(db, ...) + DB_File db + ALIAS: UNSHIFT = 1 + CODE: + { + DBTKEY key ; + DBT value ; + int i ; + int One ; + DB * Db = db->dbp ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; +#ifdef DB_VERSION_MAJOR + /* get the first value */ + RETVAL = do_SEQ(db, key, value, DB_FIRST) ; + RETVAL = 0 ; +#else + RETVAL = -1 ; +#endif + for (i = items-1 ; i > 0 ; --i) + { + value.data = SvPV(ST(i), PL_na) ; + value.size = PL_na ; + One = 1 ; + key.data = &One ; + key.size = sizeof(int) ; +#ifdef DB_VERSION_MAJOR + RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ; +#else + RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ; +#endif + if (RETVAL != 0) + break; + } + } + OUTPUT: + RETVAL + +I32 +pop(db) + DB_File db + ALIAS: POP = 1 + CODE: + { + DBTKEY key ; + DBT value ; + DB * Db = db->dbp ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; + + /* First get the final value */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + /* the call to del will trash value, so take a copy now */ + OutputValue(ST(0), value) ; + RETVAL = db_del(db, key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv(ST(0), &PL_sv_undef); + } + } + +I32 +shift(db) + DB_File db + ALIAS: SHIFT = 1 + CODE: + { + DBT value ; + DBTKEY key ; + DB * Db = db->dbp ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; + /* get the first value */ + RETVAL = do_SEQ(db, key, value, R_FIRST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + /* the call to del will trash value, so take a copy now */ + OutputValue(ST(0), value) ; + RETVAL = db_del(db, key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv (ST(0), &PL_sv_undef) ; + } + } + + +I32 +push(db, ...) + DB_File db + ALIAS: PUSH = 1 + CODE: + { + DBTKEY key ; + DBTKEY * keyptr = &key ; + DBT value ; + DB * Db = db->dbp ; + int i ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; + /* Set the Cursor to the Last element */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; + if (RETVAL >= 0) + { + if (RETVAL == 1) + keyptr = &empty ; +#ifdef DB_VERSION_MAJOR + for (i = 1 ; i < items ; ++i) + { + + ++ (* (int*)key.data) ; + value.data = SvPV(ST(i), PL_na) ; + value.size = PL_na ; + RETVAL = (Db->put)(Db, NULL, &key, &value, 0) ; + if (RETVAL != 0) + break; + } +#else + for (i = items - 1 ; i > 0 ; --i) + { + value.data = SvPV(ST(i), PL_na) ; + value.size = PL_na ; + RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ; + if (RETVAL != 0) + break; + } +#endif + } + } + OUTPUT: + RETVAL + + +I32 +length(db) + DB_File db + ALIAS: FETCHSIZE = 1 + CODE: + CurrentDB = db ; + RETVAL = GetArrayLength(db) ; + OUTPUT: + RETVAL + + +# +# Now provide an interface to the rest of the DB functionality +# + +int +db_del(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + CODE: + CurrentDB = db ; + RETVAL = db_del(db, key, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + + +int +db_get(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value = NO_INIT + u_int flags + CODE: + CurrentDB = db ; + DBT_flags(value) ; + RETVAL = db_get(db, key, value, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + value + +int +db_put(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + CODE: + CurrentDB = db ; + RETVAL = db_put(db, key, value, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_KEYEXIST) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key); + +int +db_fd(db) + DB_File db + int status = 0 ; + CODE: + CurrentDB = db ; +#ifdef DB_VERSION_MAJOR + RETVAL = -1 ; + status = (db->in_memory + ? -1 + : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ; + if (status != 0) + RETVAL = -1 ; +#else + RETVAL = (db->in_memory + ? -1 + : ((db->dbp)->fd)(db->dbp) ) ; +#endif + OUTPUT: + RETVAL + +int +db_sync(db, flags=0) + DB_File db + u_int flags + CODE: + CurrentDB = db ; + RETVAL = db_sync(db, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; +#endif + OUTPUT: + RETVAL + + +int +db_seq(db, key, value, flags) + DB_File db + DBTKEY key + DBT value = NO_INIT + u_int flags + CODE: + CurrentDB = db ; + DBT_flags(value) ; + RETVAL = db_seq(db, key, value, flags); +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + key + value + diff --git a/contrib/perl5/ext/DB_File/DB_File_BS b/contrib/perl5/ext/DB_File/DB_File_BS new file mode 100644 index 0000000..9282c49 --- /dev/null +++ b/contrib/perl5/ext/DB_File/DB_File_BS @@ -0,0 +1,6 @@ +# NeXT needs /usr/lib/libposix.a to load along with DB_File.so +if ( $dlsrc eq "dl_next.xs" ) { + @DynaLoader::dl_resolve_using = ( '/usr/lib/libposix.a' ); +} + +1; diff --git a/contrib/perl5/ext/DB_File/Makefile.PL b/contrib/perl5/ext/DB_File/Makefile.PL new file mode 100644 index 0000000..dbe19f1 --- /dev/null +++ b/contrib/perl5/ext/DB_File/Makefile.PL @@ -0,0 +1,20 @@ +use ExtUtils::MakeMaker 5.16 ; +use Config ; + +# OS2 is a special case, so check for it now. +my $OS2 = "-DOS2" if $Config{'osname'} eq 'os2' ; + +my $LIB = "-ldb" ; +# so is win32 +$LIB = "-llibdb" if $^O eq 'MSWin32' ; + +WriteMakefile( + NAME => 'DB_File', + LIBS => ["-L/usr/local/lib $LIB"], + MAN3PODS => ' ', # Pods will be built by installman. + #INC => '-I/usr/local/include', + VERSION_FROM => 'DB_File.pm', + XSPROTOARG => '-noprototypes', + DEFINE => "$OS2", + ); + diff --git a/contrib/perl5/ext/DB_File/dbinfo b/contrib/perl5/ext/DB_File/dbinfo new file mode 100644 index 0000000..9640ba4 --- /dev/null +++ b/contrib/perl5/ext/DB_File/dbinfo @@ -0,0 +1,96 @@ +#!/usr/local/bin/perl + +# Name: dbinfo -- identify berkeley DB version used to create +# a database file +# +# Author: Paul Marquess +# Version: 1.01 +# Date 16th April 1998 +# +# Copyright (c) 1998 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. + +# Todo: Print more stats on a db file, e.g. no of records +# add log/txn/lock files + +use strict ; + +my %Data = + ( + 0x053162 => { + Type => "Btree", + Versions => + { + 1 => "Unknown (older than 1.71)", + 2 => "Unknown (older than 1.71)", + 3 => "1.71 -> 1.85, 1.86", + 4 => "Unknown", + 5 => "2.0.0 -> 2.3.0", + 6 => "2.3.1 or greater", + } + }, + 0x061561 => { + Type => "Hash", + Versions => + { + 1 => "Unknown (older than 1.71)", + 2 => "1.71 -> 1.85", + 3 => "1.86", + 4 => "2.0.0 -> 2.1.0", + 5 => "2.2.6 or greater", + } + }, + ) ; + +die "Usage: dbinfo file\n" unless @ARGV == 1 ; + +print "testing file $ARGV[0]...\n\n" ; +open (F, "<$ARGV[0]") or die "Cannot open file $ARGV[0]: $!\n" ; + +my $buff ; +read F, $buff, 20 ; + +my (@info) = unpack("NNNNN", $buff) ; +my (@info1) = unpack("VVVVV", $buff) ; +my ($magic, $version, $endian) ; + +if ($Data{$info[0]}) # first try DB 1.x format +{ + $magic = $info[0] ; + $version = $info[1] ; + $endian = "Unknown" ; +} +elsif ($Data{$info[3]}) # next DB 2.x big endian +{ + $magic = $info[3] ; + $version = $info[4] ; + $endian = "Big Endian" ; +} +elsif ($Data{$info1[3]}) # next DB 2.x little endian +{ + $magic = $info1[3] ; + $version = $info1[4] ; + $endian = "Little Endian" ; +} +else + { die "not a Berkeley DB database file.\n" } + +my $type = $Data{$magic} ; +my $magic = sprintf "%06X", $magic ; + +my $ver_string = "Unknown" ; +$ver_string = $type->{Versions}{$version} + if defined $type->{Versions}{$version} ; + +print <<EOM ; +File Type: Berkeley DB $type->{Type} file. +File Version ID: $version +Built with Berkeley DB: $ver_string +Byte Order: $endian +Magic: $magic +EOM + +close F ; + +exit ; diff --git a/contrib/perl5/ext/DB_File/typemap b/contrib/perl5/ext/DB_File/typemap new file mode 100644 index 0000000..7af55ae --- /dev/null +++ b/contrib/perl5/ext/DB_File/typemap @@ -0,0 +1,41 @@ +# typemap for Perl 5 interface to Berkeley +# +# written by Paul Marquess (pmarquess@bfsec.bt.co.uk) +# last modified 13th May 1998 +# version 1.59 +# +#################################### DB SECTION +# +# + +u_int T_U_INT +DB_File T_PTROBJ +DBT T_dbtdatum +DBTKEY T_dbtkeydatum + +INPUT +T_dbtkeydatum + if (db->type != DB_RECNO) { + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + DBT_flags($var); + } + else { + Value = GetRecnoKey(db, SvIV($arg)) ; + $var.data = & Value; + $var.size = (int)sizeof(recno_t); + DBT_flags($var); + } +T_dbtdatum + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + DBT_flags($var); + +OUTPUT + +T_dbtkeydatum + OutputKey($arg, $var) +T_dbtdatum + OutputValue($arg, $var) +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); |
