diff options
Diffstat (limited to 'contrib/perl5/ext/DB_File')
| -rw-r--r-- | contrib/perl5/ext/DB_File/Changes | 336 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/DB_File.pm | 2072 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/DB_File.xs | 2071 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/DB_File_BS | 6 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/Makefile.PL | 29 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/dbinfo | 109 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/hints/dynixptx.pl | 3 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/hints/sco.pl | 2 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/typemap | 44 | ||||
| -rw-r--r-- | contrib/perl5/ext/DB_File/version.c | 81 |
10 files changed, 0 insertions, 4753 deletions
diff --git a/contrib/perl5/ext/DB_File/Changes b/contrib/perl5/ext/DB_File/Changes deleted file mode 100644 index eda270d..0000000 --- a/contrib/perl5/ext/DB_File/Changes +++ /dev/null @@ -1,336 +0,0 @@ - -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 - -1.61 19th November 1998 - - Added a note to README about how to build Berkeley DB 2.x when - using HP-UX. - Minor modifications to get the module to build with DB 2.5.x - Fixed a typo in the definition of O_RDONLY, courtesy of Mark Kettenis. - -1.62 30th November 1998 - - Added hints/dynixptx.pl. - Fixed typemap -- 1.61 used PL_na instead of na - -1.63 19th December 1998 - - * Fix to allow DB 2.6.x to build with DB_File - * Documentation updated to use push,pop etc in the RECNO example & - to include the find_dup & del_dup methods. - -1.64 21st February 1999 - - * Tidied the 1.x to 2.x flag mapping code. - * Added a patch from Mark Kettenis <kettenis@wins.uva.nl> to fix a flag - mapping problem with O_RDONLY on the Hurd - * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail. - -1.65 6th March 1999 - - * Fixed a bug in the recno PUSH logic. - * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2 - -1.66 15th March 1999 - - * Added DBM Filter code - -1.67 6th June 1999 - - * Added DBM Filter documentation to DB_File.pm - - * Fixed DBM Filter code to work with 5.004 - - * A few instances of newSVpvn were used in 1.66. This isn't available in - Perl 5.004_04 or earlier. Replaced with newSVpv. - -1.68 22nd July 1999 - - * Merged changes from 5.005_58 - - * Fixed a bug in R_IBEFORE & R_IAFTER procesing in Berkeley DB - 2 databases. - - * Added some of the examples in the POD into the test harness. - -1.69 3rd August 1999 - - * fixed a bug in push -- DB_APPEND wasn't working properly. - - * Fixed the R_SETCURSOR bug introduced in 1.68 - - * Added a new Perl variable $DB_File::db_ver - -1.70 4th August 1999 - - * Initialise $DB_File::db_ver and $DB_File::db_version with - GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. - - * Added a BOOT check to test for equivalent versions of db.h & - libdb.a/so. - -1.71 7th September 1999 - - * Fixed a bug that prevented 1.70 from compiling under win32 - - * Updated to support Berkeley DB 3.x - - * Updated dbinfo for Berkeley DB 3.x file formats. - -1.72 16th January 2000 - - * Added hints/sco.pl - - * The module will now use XSLoader when it is available. When it - isn't it will use DynaLoader. - - * The locking section in DB_File.pm has been discredited. Many thanks - to David Harris for spotting the underlying problem, contributing - the updates to the documentation and writing DB_File::Lock (available - on CPAN). - -1.73 31st May 2000 - - * Added support in version.c for building with threaded Perl. - - * Berkeley DB 3.1 has reenabled support for null keys. The test - harness has been updated to reflect this. - -1.74 10th December 2000 - - * A "close" call in DB_File.xs needed parenthesised to stop win32 from - thinking it was one of its macros. - - * Updated dbinfo to support Berkeley DB 3.1 file format changes. - - * DB_File.pm & the test hasness now use the warnings pragma (when - available). - - * Included Perl core patch 7703 -- size argument for hash_cb is different - for Berkeley DB 3.x - - * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C - treatment. - - * @a = () produced the warning 'Argument "" isn't numeric in entersub' - This has been fixed. Thanks to Edward Avis for spotting this bug. - - * Added note about building under Linux. Included patches. - - * Included Perl core patch 8068 -- fix for bug 20001013.009 - When run with warnings enabled "$hash{XX} = undef " produced an - "Uninitialized value" warning. This has been fixed. - -1.75 17th December 2000 - - * Fixed perl core patch 7703 - - * Added suppport to allow DB_File to be built with Berkeley DB 3.2 -- - btree_compare, btree_prefix and hash_cb needed to be changed. - - * Updated dbinfo to support Berkeley DB 3.2 file format changes. - - diff --git a/contrib/perl5/ext/DB_File/DB_File.pm b/contrib/perl5/ext/DB_File/DB_File.pm deleted file mode 100644 index c830216..0000000 --- a/contrib/perl5/ext/DB_File/DB_File.pm +++ /dev/null @@ -1,2072 +0,0 @@ -# DB_File.pm -- Perl 5 interface to Berkeley DB -# -# written by Paul Marquess (Paul.Marquess@btinternet.com) -# last modified 17th December 2000 -# version 1.75 -# -# Copyright (c) 1995-2000 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 warnings; -use strict; -use Carp; -require Tie::Hash; -@DB_File::HASHINFO::ISA = qw(Tie::Hash); - -sub new -{ - my $pkg = shift ; - my %x ; - tie %x, $pkg ; - bless \%x, $pkg ; -} - - -sub TIEHASH -{ - my $pkg = shift ; - - bless { VALID => { 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 warnings; -use strict ; - -@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; - -sub TIEHASH -{ - my $pkg = shift ; - - bless { VALID => { map {$_, 1} - qw( bval cachesize psize flags lorder reclen bfname ) - }, - GOT => {}, - }, $pkg ; -} - -package DB_File::BTREEINFO ; - -use warnings; -use strict ; - -@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ; - -sub TIEHASH -{ - my $pkg = shift ; - - bless { VALID => { map {$_, 1} - qw( flags cachesize maxkeypage minkeypage psize - compare prefix lorder ) - }, - GOT => {}, - }, $pkg ; -} - - -package DB_File ; - -use warnings; -use strict; -use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO - $db_version $use_XSLoader - ) ; -use Carp; - - -$VERSION = "1.75" ; - -#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; -BEGIN { - $use_XSLoader = 1 ; - eval { require XSLoader } ; - - if ($@) { - $use_XSLoader = 0 ; - require DynaLoader; - @ISA = qw(DynaLoader); - } -} - -push @ISA, qw(Tie::Hash Exporter); -@EXPORT = qw( - $DB_BTREE $DB_HASH $DB_RECNO - - BTREEMAGIC - BTREEVERSION - DB_LOCK - DB_SHMEM - DB_TXN - HASHMAGIC - HASHVERSION - MAX_PAGE_NUMBER - MAX_PAGE_OFFSET - MAX_REC_NUMBER - RET_ERROR - RET_SPECIAL - RET_SUCCESS - R_CURSOR - R_DUP - R_FIRST - R_FIXEDLEN - R_IAFTER - R_IBEFORE - R_LAST - R_NEXT - R_NOKEY - R_NOOVERWRITE - R_PREV - R_RECNOSYNC - R_SETCURSOR - R_SNAPSHOT - __R_UNUSED - -); - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - if ($! =~ /Invalid/ || $!{EINVAL}) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - my($pack,$file,$line) = caller; - croak "Your vendor has not defined DB macro $constname, used at $file line $line. -"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - - -eval { - # Make all Fcntl O_XXX constants available for importing - require Fcntl; - my @O = grep /^O_/, @Fcntl::EXPORT; - Fcntl->import(@O); # first we import what we want to export - push(@EXPORT, @O); -}; - -if ($use_XSLoader) - { XSLoader::load("DB_File", $VERSION)} -else - { bootstrap DB_File $VERSION } - -# 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 = 0 ; - my $value = "" ; - my $status = $self->seq($key, $value, R_FIRST()); - my @keys; - - while ($status == 0) { - push @keys, $key; - $status = $self->seq($key, $value, R_NEXT()); - } - foreach $key (reverse @keys) { - my $s = $self->del($key); - } -} - -sub EXTEND { } - -sub STORESIZE -{ - my $self = shift; - my $length = shift ; - my $current_length = $self->length() ; - - if ($length < $current_length) { - my $key ; - for ($key = $current_length - 1 ; $key >= $length ; -- $key) - { $self->del($key) } - } - elsif ($length > $current_length) { - $self->put($length-1, "") ; - } -} - -sub find_dup -{ - croak "Usage: \$db->find_dup(key,value)\n" - unless @_ == 3 ; - - my $db = shift ; - my ($origkey, $value_wanted) = @_ ; - my ($key, $value) = ($origkey, 0); - my ($status) = 0 ; - - for ($status = $db->seq($key, $value, R_CURSOR() ) ; - $status == 0 ; - $status = $db->seq($key, $value, R_NEXT() ) ) { - - return 0 if $key eq $origkey and $value eq $value_wanted ; - } - - return $status ; -} - -sub del_dup -{ - croak "Usage: \$db->del_dup(key,value)\n" - unless @_ == 3 ; - - my $db = shift ; - my ($key, $value) = @_ ; - my ($status) = $db->find_dup($key, $value) ; - return $status if $status != 0 ; - - $status = $db->del($key, R_CURSOR() ) ; - return $status ; -} - -sub get_dup -{ - croak "Usage: \$db->get_dup(key [,flag])\n" - unless @_ == 2 or @_ == 3 ; - - my $db = shift ; - my $key = shift ; - my $flag = shift ; - my $value = 0 ; - my $origkey = $key ; - my $wantarray = wantarray ; - my %values = () ; - my @values = () ; - my $counter = 0 ; - my $status = 0 ; - - # iterate through the database until either EOF ($status == 0) - # or a different key is encountered ($key ne $origkey). - for ($status = $db->seq($key, $value, R_CURSOR()) ; - $status == 0 and $key eq $origkey ; - $status = $db->seq($key, $value, R_NEXT()) ) { - - # save the value or count number of matches - if ($wantarray) { - if ($flag) - { ++ $values{$value} } - else - { push (@values, $value) } - } - else - { ++ $counter } - - } - - return ($wantarray ? ($flag ? %values : @values) : $counter) ; -} - - -1; -__END__ - -=head1 NAME - -DB_File - Perl5 access to Berkeley DB version 1.x - -=head1 SYNOPSIS - - use DB_File ; - - [$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ; - [$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ; - [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ; - - $status = $X->del($key [, $flags]) ; - $status = $X->put($key, $value [, $flags]) ; - $status = $X->get($key, $value [, $flags]) ; - $status = $X->seq($key, $value, $flags) ; - $status = $X->sync([$flags]) ; - $status = $X->fd ; - - # BTREE only - $count = $X->get_dup($key) ; - @list = $X->get_dup($key) ; - %list = $X->get_dup($key, 1) ; - $status = $X->find_dup($key, $value) ; - $status = $X->del_dup($key, $value) ; - - # RECNO only - $a = $X->length; - $a = $X->pop ; - $X->push(list); - $a = $X->shift; - $X->unshift(list); - - # DBM Filters - $old_filter = $db->filter_store_key ( sub { ... } ) ; - $old_filter = $db->filter_store_value( sub { ... } ) ; - $old_filter = $db->filter_fetch_key ( sub { ... } ) ; - $old_filter = $db->filter_fetch_value( sub { ... } ) ; - - untie %hash ; - untie @array ; - -=head1 DESCRIPTION - -B<DB_File> is a module which allows Perl programs to make use of the -facilities provided by Berkeley DB version 1.x (if you have a newer -version of DB, see L<Using DB_File with Berkeley DB version 2 or 3>). -It is assumed that you have a copy of the Berkeley DB manual pages at -hand when reading this documentation. The interface defined here -mirrors the Berkeley DB interface closely. - -Berkeley DB is a C library which provides a consistent interface to a -number of database formats. B<DB_File> provides an interface to all -three of the database types currently supported by Berkeley DB. - -The file types are: - -=over 5 - -=item B<DB_HASH> - -This database type allows arbitrary key/value pairs to be stored in data -files. This is equivalent to the functionality provided by other -hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though, -the files created using DB_HASH are not compatible with any of the -other packages mentioned. - -A default hashing algorithm, which will be adequate for most -applications, is built into Berkeley DB. If you do need to use your own -hashing algorithm it is possible to write your own in Perl and have -B<DB_File> use it instead. - -=item B<DB_BTREE> - -The btree format allows arbitrary key/value pairs to be stored in a -sorted, balanced binary tree. - -As with the DB_HASH format, it is possible to provide a user defined -Perl routine to perform the comparison of keys. By default, though, the -keys are stored in lexical order. - -=item B<DB_RECNO> - -DB_RECNO allows both fixed-length and variable-length flat text files -to be manipulated using the same key/value pair interface as in DB_HASH -and DB_BTREE. In this case the key will consist of a record (line) -number. - -=back - -=head2 Using DB_File with Berkeley DB version 2 or 3 - -Although B<DB_File> is intended to be used with Berkeley DB version 1, -it can also be used with version 2.or 3 In this case the interface is -limited to the functionality provided by Berkeley DB 1.x. Anywhere the -version 2 or 3 interface differs, B<DB_File> arranges for it to work -like version 1. This feature allows B<DB_File> scripts that were built -with version 1 to be migrated to version 2 or 3 without any changes. - -If you want to make use of the new features available in Berkeley DB -2.x or greater, use the Perl module B<BerkeleyDB> instead. - -B<Note:> The database file format has changed in both Berkeley DB -version 2 and 3. If you cannot recreate your databases, you must dump -any existing databases with the C<db_dump185> utility that comes with -Berkeley DB. -Once you have rebuilt DB_File to use Berkeley DB version 2 or 3, your -databases can be recreated using C<db_load>. Refer to the Berkeley DB -documentation for further details. - -Please read L<"COPYRIGHT"> before using version 2.x or 3.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 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 - 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 warnings ; - 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 ; - - unlink "tree" ; - 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 warnings ; - 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 (sort 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 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 - 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>. - -To make life easier when dealing with duplicate keys, B<DB_File> comes with -a few utility methods. - -=head2 The get_dup() Method - -The C<get_dup> method assists 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: - - 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 - or die "Cannot open $filename: $!\n"; - - 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 = sort $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 The find_dup() Method - - $status = $X->find_dup($key, $value) ; - -This method checks for the existence of a specific key/value pair. If the -pair exists, the cursor is left pointing to the pair and the method -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 - 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 ; - -prints this - - Larry Wall is there - Harry Wall is not there - - -=head2 The del_dup() Method - - $status = $X->del_dup($key, $value) ; - -This method deletes a specific key/value pair. It returns -0 if they exist and have been deleted successfully. -Otherwise the method returns a non-zero value. - -Again assuming the existence of the C<tree> database - - use warnings ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h $found) ; - - my $filename = "tree" ; - - # 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"; - - $x->del_dup("Wall", "Larry") ; - - $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; - print "Larry Wall is $found there\n" ; - - undef $x ; - untie %h ; - -prints this - - Larry Wall is not there - -=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 warnings ; - 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 to 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 (if you are using a version -of Perl earlier than 5.004_57 this example won't work -- see -L<Extra RECNO Methods> for a workaround). - - use warnings ; - use strict ; - use DB_File ; - - my $filename = "text" ; - unlink $filename ; - - my @h ; - tie @h, "DB_File", $filename, 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" ; - - push @h, "green", "black" ; - - my $elements = scalar @h ; - print "The array contains $elements entries\n" ; - - my $last = pop @h ; - print "popped $last\n" ; - - unshift @h, "white" ; - my $first = shift @h ; - print "shifted $first\n" ; - - # 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: - - The array contains 5 entries - popped black - shifted white - Element 1 Exists with value blue - The last element is green - The 2nd last element is yellow - -=head2 Extra RECNO Methods - -If you are using a version of Perl earlier than 5.004_57, the tied -array interface is quite limited. In the example script above -C<push>, C<pop>, C<shift>, C<unshift> -or determining the array length will not work with a 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 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 - 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: The Trouble with fd> for an explanation for why you should -not use C<fd> 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 DBM FILTERS - -A DBM Filter is a piece of code that is be used when you I<always> -want to make the same transformation to all keys and/or values in a -DBM database. - -There are four methods associated with DBM Filters. All work identically, -and each is used to install (or uninstall) a single DBM Filter. Each -expects a single parameter, namely a reference to a sub. The only -difference between them is the place that the filter is installed. - -To summarise: - -=over 5 - -=item B<filter_store_key> - -If a filter has been installed with this method, it will be invoked -every time you write a key to a DBM database. - -=item B<filter_store_value> - -If a filter has been installed with this method, it will be invoked -every time you write a value to a DBM database. - - -=item B<filter_fetch_key> - -If a filter has been installed with this method, it will be invoked -every time you read a key from a DBM database. - -=item B<filter_fetch_value> - -If a filter has been installed with this method, it will be invoked -every time you read a value from a DBM database. - -=back - -You can use any combination of the methods, from none, to all four. - -All filter methods return the existing filter, if present, or C<undef> -in not. - -To delete a filter pass C<undef> to it. - -=head2 The Filter - -When each filter is called by Perl, a local copy of C<$_> will contain -the key or value to be filtered. Filtering is achieved by modifying -the contents of C<$_>. The return code from the filter is ignored. - -=head2 An Example -- the NULL termination problem. - -Consider the following scenario. You have a DBM database -that you need to share with a third-party C application. The C application -assumes that I<all> keys and values are NULL terminated. Unfortunately -when Perl writes to DBM databases it doesn't use NULL termination, so -your Perl application will have to manage NULL termination itself. When -you write to the database you will have to use something like this: - - $hash{"$key\0"} = "$value\0" ; - -Similarly the NULL needs to be taken into account when you are considering -the length of existing keys/values. - -It would be much better if you could ignore the NULL terminations issue -in the main application code and have a mechanism that automatically -added the terminating NULL to all keys and values whenever you write to -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 ; - - my %hash ; - my $filename = "/tmp/filt" ; - unlink $filename ; - - my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH - or die "Cannot open $filename: $!\n" ; - - # Install DBM Filters - $db->filter_fetch_key ( sub { s/\0$// } ) ; - $db->filter_store_key ( sub { $_ .= "\0" } ) ; - $db->filter_fetch_value( sub { s/\0$// } ) ; - $db->filter_store_value( sub { $_ .= "\0" } ) ; - - $hash{"abc"} = "def" ; - my $a = $hash{"ABC"} ; - # ... - undef $db ; - untie %hash ; - -Hopefully the contents of each of the filters should be -self-explanatory. Both "fetch" filters remove the terminating NULL, -and both "store" filters add a terminating NULL. - - -=head2 Another Example -- Key is a C int. - -Here is another real-life example. By default, whenever Perl writes to -a DBM database it always writes the key and value as strings. So when -you use this: - - $hash{12345} = "soemthing" ; - -the key 12345 will get stored in the DBM database as the 5 byte string -"12345". If you actually want the key to be stored in the DBM database -as a C int, you will have to use C<pack> when writing, and C<unpack> -when reading. - -Here is a DBM Filter that does it: - - use warnings ; - use strict ; - use DB_File ; - my %hash ; - my $filename = "/tmp/filt" ; - unlink $filename ; - - - my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH - or die "Cannot open $filename: $!\n" ; - - $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ; - $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ; - $hash{123} = "def" ; - # ... - undef $db ; - untie %hash ; - -This time only two filters have been used -- we only need to manipulate -the contents of the key, so it wasn't necessary to install any value -filters. - -=head1 HINTS AND TIPS - - -=head2 Locking: The Trouble with fd - -Until version 1.72 of this module, the recommended technique for locking -B<DB_File> databases was to flock the filehandle returned from the "fd" -function. Unfortunately this technique has been shown to be fundamentally -flawed (Kudos to David Harris for tracking this down). Use it at your own -peril! - -The locking technique went like this. - - $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644) - || die "dbcreat /tmp/foo.db $!"; - $fd = $db->fd; - open(DB_FH, "+<&=$fd") || die "dup $!"; - flock (DB_FH, LOCK_EX) || die "flock: $!"; - ... - $db{"Tom"} = "Jerry" ; - ... - flock(DB_FH, LOCK_UN); - undef $db; - untie %db; - close(DB_FH); - -In simple terms, this is what happens: - -=over 5 - -=item 1. - -Use "tie" to open the database. - -=item 2. - -Lock the database with fd & flock. - -=item 3. - -Read & Write to the database. - -=item 4. - -Unlock and close the database. - -=back - -Here is the crux of the problem. A side-effect of opening the B<DB_File> -database in step 2 is that an initial block from the database will get -read from disk and cached in memory. - -To see why this is a problem, consider what can happen when two processes, -say "A" and "B", both want to update the same B<DB_File> database -using the locking steps outlined above. Assume process "A" has already -opened the database and has a write lock, but it hasn't actually updated -the database yet (it has finished step 2, but not started step 3 yet). Now -process "B" tries to open the same database - step 1 will succeed, -but it will block on step 2 until process "A" releases the lock. The -important thing to notice here is that at this point in time both -processes will have cached identical initial blocks from the database. - -Now process "A" updates the database and happens to change some of the -data held in the initial buffer. Process "A" terminates, flushing -all cached data to disk and releasing the database lock. At this point -the database on disk will correctly reflect the changes made by process -"A". - -With the lock released, process "B" can now continue. It also updates the -database and unfortunately it too modifies the data that was in its -initial buffer. Once that data gets flushed to disk it will overwrite -some/all of the changes process "A" made to the database. - -The result of this scenario is at best a database that doesn't contain -what you expect. At worst the database will corrupt. - -The above won't happen every time competing process update the same -B<DB_File> database, but it does illustrate why the technique should -not be used. - -=head2 Safe ways to lock a database - -Starting with version 2.x, Berkeley DB has internal support for locking. -The companion module to this one, B<BerkeleyDB>, provides an interface -to this locking functionality. If you are serious about locking -Berkeley DB databases, I strongly recommend using B<BerkeleyDB>. - -If using B<BerkeleyDB> isn't an option, there are a number of modules -available on CPAN that can be used to implement locking. Each one -implements locking differently and has different goals in mind. It is -therefore worth knowing the difference, so that you can pick the right -one for your application. Here are the three locking wrappers: - -=over 5 - -=item B<Tie::DB_Lock> - -A B<DB_File> wrapper which creates copies of the database file for -read access, so that you have a kind of a multiversioning concurrent read -system. However, updates are still serial. Use for databases where reads -may be lengthy and consistency problems may occur. - -=item B<Tie::DB_LockFile> - -A B<DB_File> wrapper that has the ability to lock and unlock the database -while it is being used. Avoids the tie-before-flock problem by simply -re-tie-ing the database when you get or drop a lock. Because of the -flexibility in dropping and re-acquiring the lock in the middle of a -session, this can be massaged into a system that will work with long -updates and/or reads if the application follows the hints in the POD -documentation. - -=item B<DB_File::Lock> - -An extremely lightweight B<DB_File> wrapper that simply flocks a lockfile -before tie-ing the database and drops the lock after the untie. Allows -one to use the same lockfile for multiple databases to avoid deadlock -problems, if desired. Use for databases where updates are reads are -quick and simple flock locking semantics are enough. - -=back - -=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. See L<DBM FILTERS> for a generic way to work around this problem. - -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 warnings ; - 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 already 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 warnings ; - 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 REFERENCES - -Articles that are either about B<DB_File> or make use of it. - -=over 5 - -=item 1. - -I<Full-Text Searching in Perl>, Tim Kientzle (tkientzle@ddj.com), -Dr. Dobb's Journal, Issue 295, January 1999, pp 34-41 - -=back - -=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, 2.x or -3.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>. -All versions 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-1999 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 -F<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)>, -L<dbmfilter> - -=head1 AUTHOR - -The DB_File interface was written by Paul Marquess -E<lt>Paul.Marquess@btinternet.comE<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 deleted file mode 100644 index fa3bb33..0000000 --- a/contrib/perl5/ext/DB_File/DB_File.xs +++ /dev/null @@ -1,2071 +0,0 @@ -/* - - DB_File.xs -- Perl 5 interface to Berkeley DB - - written by Paul Marquess <Paul.Marquess@btinternet.com> - last modified 17 December 2000 - version 1.75 - - All comments/suggestions/problems are welcome - - Copyright (c) 1995-2000 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 - 1.61 - added flagSet macro for DB 2.5.x - fixed typo in O_RDONLY test. - 1.62 - No change to DB_File.xs - 1.63 - Fix to alllow DB 2.6.x to build. - 1.64 - Tidied up the 1.x to 2.x flags mapping code. - Added a patch from Mark Kettenis <kettenis@wins.uva.nl> - to fix a flag mapping problem with O_RDONLY on the Hurd - 1.65 - Fixed a bug in the PUSH logic. - Added BOOT check that using 2.3.4 or greater - 1.66 - Added DBM filter code - 1.67 - Backed off the use of newSVpvn. - Fixed DBM Filter code for Perl 5.004. - Fixed a small memory leak in the filter code. - 1.68 - fixed backward compatability bug with R_IAFTER & R_IBEFORE - merged in the 5.005_58 changes - 1.69 - fixed a bug in push -- DB_APPEND wasn't working properly. - Fixed the R_SETCURSOR bug introduced in 1.68 - Added a new Perl variable $DB_File::db_ver - 1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with - GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. - Added a BOOT check to test for equivalent versions of db.h & - libdb.a/so. - 1.71 - Support for Berkeley DB version 3. - Support for Berkeley DB 2/3's backward compatability mode. - Rewrote push - 1.72 - No change to DB_File.xs - 1.73 - No change to DB_File.xs - 1.74 - A call to open needed parenthesised to stop it clashing - with a win32 macro. - Added Perl core patches 7703 & 7801. - 1.75 - Fixed Perl core patch 7703. - Added suppport to allow DB_File to be built with - Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb - needed to be changed. - -*/ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifndef PERL_VERSION -# include "patchlevel.h" -# define PERL_REVISION 5 -# define PERL_VERSION PATCHLEVEL -# define PERL_SUBVERSION SUBVERSION -#endif - -#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 )) - -# define PL_sv_undef sv_undef -# define PL_na na - -#endif - -/* DEFSV appears first in 5.004_56 */ -#ifndef DEFSV -# define DEFSV GvSV(defgv) -#endif - -/* 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 - -#ifdef COMPAT185 -# include <db_185.h> -#else -# include <db.h> -#endif - -#ifdef CAN_PROTOTYPE -extern void __getBerkeleyDBInfo(void); -#endif - -#ifndef pTHX -# define pTHX -# define pTHX_ -# define aTHX -# define aTHX_ -#endif - -#ifndef newSVpvn -# define newSVpvn(a,b) newSVpv(a,b) -#endif - -#include <fcntl.h> - -/* #define TRACE */ -#define DBM_FILTERING - -#ifdef TRACE -# define Trace(x) printf x -#else -# define Trace(x) -#endif - - -#define DBT_clear(x) Zero(&x, 1, DBT) ; - -#ifdef DB_VERSION_MAJOR - -#if DB_VERSION_MAJOR == 2 -# define BERKELEY_DB_1_OR_2 -#endif - -#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2) -# define AT_LEAST_DB_3_2 -#endif - -/* 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 */ -#if DB_VERSION_MAJOR == 2 - typedef DB_INFO INFO ; -#else /* DB_VERSION_MAJOR > 2 */ -# define DB_FIXEDLEN (0x8000) -#endif /* DB_VERSION_MAJOR == 2 */ - -/* 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 - -#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 -# define R_SETCURSOR 0x800000 -#else -# define R_SETCURSOR (-100) -#endif - -#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 - -#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 -# define flagSet(flags, bitmask) ((flags) & (bitmask)) -#else -# define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask)) -#endif - -#else /* db version 1.x */ - -#define BERKELEY_DB_1 -#define BERKELEY_DB_1_OR_2 - -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) -#define flagSet(flags, bitmask) ((flags) & (bitmask)) - -#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->cursor->c_close(db->cursor),\ - (db->dbp->close)(db->dbp, 0) ) -#define db_close(db) ((db->dbp)->close)(db->dbp, 0) -#define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \ - ? ((db->cursor)->c_del)(db->cursor, 0) \ - : ((db->dbp)->del)(db->dbp, NULL, &key, flags) ) - -#else /* ! DB_VERSION_MAJOR */ - -#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 /* ! DB_VERSION_MAJOR */ - - -#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 ; -#ifdef BERKELEY_DB_1_OR_2 - INFO info ; -#endif -#ifdef DB_VERSION_MAJOR - DBC * cursor ; -#endif -#ifdef DBM_FILTERING - SV * filter_fetch_key ; - SV * filter_store_key ; - SV * filter_fetch_value ; - SV * filter_store_value ; - int filtering ; -#endif /* DBM_FILTERING */ - - } DB_File_type; - -typedef DB_File_type * DB_File ; -typedef DBT DBTKEY ; - -#ifdef DBM_FILTERING - -#define ckFilter(arg,type,name) \ - if (db->type) { \ - SV * save_defsv ; \ - /* printf("filtering %s\n", name) ;*/ \ - if (db->filtering) \ - croak("recursion detected in %s", name) ; \ - db->filtering = TRUE ; \ - save_defsv = newSVsv(DEFSV) ; \ - sv_setsv(DEFSV, arg) ; \ - PUSHMARK(sp) ; \ - (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ - sv_setsv(arg, DEFSV) ; \ - sv_setsv(DEFSV, save_defsv) ; \ - SvREFCNT_dec(save_defsv) ; \ - db->filtering = FALSE ; \ - /*printf("end of filtering %s\n", name) ;*/ \ - } - -#else - -#define ckFilter(arg,type, name) - -#endif /* DBM_FILTERING */ - -#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) ; \ - ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ - } \ - } - -#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); \ - ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ - } \ - } - - -/* 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 -#ifdef CAN_PROTOTYPE -db_put(DB_File db, DBTKEY key, DBT value, u_int flags) -#else -db_put(db, key, value, flags) -DB_File db ; -DBTKEY key ; -DBT value ; -u_int flags ; -#endif -{ - int status ; - - if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) { - DBC * temp_cursor ; - DBT l_key, l_value; - -#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 - if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0) -#else - if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0) -#endif - return (-1) ; - - memset(&l_key, 0, sizeof(l_key)); - l_key.data = key.data; - l_key.size = key.size; - memset(&l_value, 0, sizeof(l_value)); - l_value.data = value.data; - l_value.size = value.size; - - if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) { - (void)temp_cursor->c_close(temp_cursor); - return (-1); - } - - status = temp_cursor->c_put(temp_cursor, &key, &value, flags); - (void)temp_cursor->c_close(temp_cursor); - - return (status) ; - } - - - if (flagSet(flags, R_CURSOR)) { - return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT); - } - - if (flagSet(flags, R_SETCURSOR)) { - if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0) - return -1 ; - return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE); - - } - - return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ; - -} - -#endif /* DB_VERSION_MAJOR */ - - -static int -#ifdef AT_LEAST_DB_3_2 - -#ifdef CAN_PROTOTYPE -btree_compare(DB * db, const DBT *key1, const DBT *key2) -#else -btree_compare(db, key1, key2) -DB * db ; -const DBT * key1 ; -const DBT * key2 ; -#endif /* CAN_PROTOTYPE */ - -#else /* Berkeley DB < 3.2 */ - -#ifdef CAN_PROTOTYPE -btree_compare(const DBT *key1, const DBT *key2) -#else -btree_compare(key1, key2) -const DBT * key1 ; -const DBT * key2 ; -#endif - -#endif - -{ -#ifdef dTHX - dTHX; -#endif - dSP ; - void * data1, * data2 ; - int retval ; - int count ; - - data1 = key1->data ; - data2 = key2->data ; - -#ifndef newSVpvn - /* 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 = "" ; -#endif - - ENTER ; - SAVETMPS; - - PUSHMARK(SP) ; - EXTEND(SP,2) ; - PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); - PUSHs(sv_2mortal(newSVpvn(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 -#ifdef AT_LEAST_DB_3_2 - -#ifdef CAN_PROTOTYPE -btree_prefix(DB * db, const DBT *key1, const DBT *key2) -#else -btree_prefix(db, key1, key2) -Db * db ; -const DBT * key1 ; -const DBT * key2 ; -#endif - -#else /* Berkeley DB < 3.2 */ - -#ifdef CAN_PROTOTYPE -btree_prefix(const DBT *key1, const DBT *key2) -#else -btree_prefix(key1, key2) -const DBT * key1 ; -const DBT * key2 ; -#endif - -#endif -{ -#ifdef dTHX - dTHX; -#endif - dSP ; - void * data1, * data2 ; - int retval ; - int count ; - - data1 = key1->data ; - data2 = key2->data ; - -#ifndef newSVpvn - /* 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 = "" ; -#endif - - ENTER ; - SAVETMPS; - - PUSHMARK(SP) ; - EXTEND(SP,2) ; - PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); - PUSHs(sv_2mortal(newSVpvn(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) ; -} - - -#ifdef BERKELEY_DB_1 -# define HASH_CB_SIZE_TYPE size_t -#else -# define HASH_CB_SIZE_TYPE u_int32_t -#endif - -static DB_Hash_t -#ifdef AT_LEAST_DB_3_2 - -#ifdef CAN_PROTOTYPE -hash_cb(DB * db, const void *data, u_int32_t size) -#else -hash_cb(db, data, size) -DB * db ; -const void * data ; -HASH_CB_SIZE_TYPE size ; -#endif - -#else /* Berkeley DB < 3.2 */ - -#ifdef CAN_PROTOTYPE -hash_cb(const void *data, HASH_CB_SIZE_TYPE size) -#else -hash_cb(data, size) -const void * data ; -HASH_CB_SIZE_TYPE size ; -#endif - -#endif -{ -#ifdef dTHX - dTHX; -#endif - dSP ; - int retval ; - int count ; - -#ifndef newSVpvn - if (size == 0) - data = "" ; -#endif - - /* DGH - Next two lines added to fix corrupted stack problem */ - ENTER ; - SAVETMPS; - - PUSHMARK(SP) ; - - XPUSHs(sv_2mortal(newSVpvn((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) ; -} - - -#if defined(TRACE) && defined(BERKELEY_DB_1_OR_2) - -static void -#ifdef CAN_PROTOTYPE -PrintHash(INFO *hash) -#else -PrintHash(hash) -INFO * hash ; -#endif -{ - 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 -#ifdef CAN_PROTOTYPE -PrintRecno(INFO *recno) -#else -PrintRecno(recno) -INFO * recno ; -#endif -{ - 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 -#ifdef CAN_PROTOTYPE -PrintBtree(INFO *btree) -#else -PrintBtree(btree) -INFO * btree ; -#endif -{ - 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 -#ifdef CAN_PROTOTYPE -GetArrayLength(pTHX_ DB_File db) -#else -GetArrayLength(db) -DB_File db ; -#endif -{ - DBT key ; - DBT value ; - int RETVAL ; - - DBT_clear(key) ; - DBT_clear(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 -#ifdef CAN_PROTOTYPE -GetRecnoKey(pTHX_ DB_File db, I32 value) -#else -GetRecnoKey(db, value) -DB_File db ; -I32 value ; -#endif -{ - if (value < 0) { - /* Get the length of the array */ - I32 length = GetArrayLength(aTHX_ 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 -#ifdef CAN_PROTOTYPE -ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv) -#else -ParseOpenInfo(isHASH, name, flags, mode, sv) -int isHASH ; -char * name ; -int flags ; -int mode ; -SV * sv ; -#endif -{ - -#ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */ - - SV ** svp; - HV * action ; - DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; - void * openinfo = NULL ; - INFO * info = &RETVAL->info ; - STRLEN n_a; - -/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ - Zero(RETVAL, 1, DB_File_type) ; - - /* Default to HASH */ -#ifdef DBM_FILTERING - RETVAL->filtering = 0 ; - RETVAL->filter_fetch_key = RETVAL->filter_store_key = - RETVAL->filter_fetch_value = RETVAL->filter_store_value = -#endif /* DBM_FILTERING */ - 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,n_a) ; -#ifdef DB_VERSION_MAJOR - name = (char*) n_a ? ptr : NULL ; -#else - info->db_RE_bfname = (char*) (n_a ? 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, n_a) ; - 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, n_a) ; - 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 ; - -#if O_RDONLY == 0 - if (flags == O_RDONLY) -#else - if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) -#endif - Flags |= DB_RDONLY ; - -#ifdef O_TRUNC - 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) -#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 - status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ; -#else - status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, - 0) ; -#endif - - if (status) - RETVAL->dbp = NULL ; - - } -#else - -#if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2 - RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ; -#else - RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; -#endif /* DB_LIBRARY_COMPATIBILITY_API */ - -#endif - - return (RETVAL) ; - -#else /* Berkeley DB Version > 2 */ - - SV ** svp; - HV * action ; - DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; - DB * dbp ; - STRLEN n_a; - int status ; - -/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ - Zero(RETVAL, 1, DB_File_type) ; - - /* Default to HASH */ -#ifdef DBM_FILTERING - RETVAL->filtering = 0 ; - RETVAL->filter_fetch_key = RETVAL->filter_store_key = - RETVAL->filter_fetch_value = RETVAL->filter_store_value = -#endif /* DBM_FILTERING */ - 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) ; - - status = db_create(&RETVAL->dbp, NULL,0) ; - /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */ - if (status) { - RETVAL->dbp = NULL ; - return (RETVAL) ; - } - dbp = RETVAL->dbp ; - - 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 ; - - svp = hv_fetch(action, "hash", 4, FALSE); - - if (svp && SvOK(*svp)) - { - (void)dbp->set_h_hash(dbp, hash_cb) ; - RETVAL->hash = newSVsv(*svp) ; - } - - svp = hv_fetch(action, "ffactor", 7, FALSE); - if (svp) - (void)dbp->set_h_ffactor(dbp, SvIV(*svp)) ; - - svp = hv_fetch(action, "nelem", 5, FALSE); - if (svp) - (void)dbp->set_h_nelem(dbp, SvIV(*svp)) ; - - svp = hv_fetch(action, "bsize", 5, FALSE); - if (svp) - (void)dbp->set_pagesize(dbp, SvIV(*svp)); - - svp = hv_fetch(action, "cachesize", 9, FALSE); - if (svp) - (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; - - svp = hv_fetch(action, "lorder", 6, FALSE); - if (svp) - (void)dbp->set_lorder(dbp, SvIV(*svp)) ; - - 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 ; - - svp = hv_fetch(action, "compare", 7, FALSE); - if (svp && SvOK(*svp)) - { - (void)dbp->set_bt_compare(dbp, btree_compare) ; - RETVAL->compare = newSVsv(*svp) ; - } - - svp = hv_fetch(action, "prefix", 6, FALSE); - if (svp && SvOK(*svp)) - { - (void)dbp->set_bt_prefix(dbp, btree_prefix) ; - RETVAL->prefix = newSVsv(*svp) ; - } - - svp = hv_fetch(action, "flags", 5, FALSE); - if (svp) - (void)dbp->set_flags(dbp, SvIV(*svp)) ; - - svp = hv_fetch(action, "cachesize", 9, FALSE); - if (svp) - (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; - - svp = hv_fetch(action, "psize", 5, FALSE); - if (svp) - (void)dbp->set_pagesize(dbp, SvIV(*svp)) ; - - svp = hv_fetch(action, "lorder", 6, FALSE); - if (svp) - (void)dbp->set_lorder(dbp, SvIV(*svp)) ; - - PrintBtree(info) ; - - } - else if (sv_isa(sv, "DB_File::RECNOINFO")) - { - int fixed = FALSE ; - - if (isHASH) - croak("DB_File can only tie an array to a DB_RECNO database"); - - RETVAL->type = DB_RECNO ; - - svp = hv_fetch(action, "flags", 5, FALSE); - if (svp) { - int flags = SvIV(*svp) ; - /* remove FIXDLEN, if present */ - if (flags & DB_FIXEDLEN) { - fixed = TRUE ; - flags &= ~DB_FIXEDLEN ; - } - } - - svp = hv_fetch(action, "cachesize", 9, FALSE); - if (svp) { - status = dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; - } - - svp = hv_fetch(action, "psize", 5, FALSE); - if (svp) { - status = dbp->set_pagesize(dbp, SvIV(*svp)) ; - } - - svp = hv_fetch(action, "lorder", 6, FALSE); - if (svp) { - status = dbp->set_lorder(dbp, SvIV(*svp)) ; - } - - svp = hv_fetch(action, "bval", 4, FALSE); - if (svp && SvOK(*svp)) - { - int value ; - if (SvPOK(*svp)) - value = (int)*SvPV(*svp, n_a) ; - else - value = SvIV(*svp) ; - - if (fixed) { - status = dbp->set_re_pad(dbp, value) ; - } - else { - status = dbp->set_re_delim(dbp, value) ; - } - - } - - if (fixed) { - svp = hv_fetch(action, "reclen", 6, FALSE); - if (svp) { - u_int32_t len = (u_int32_t)SvIV(*svp) ; - status = dbp->set_re_len(dbp, len) ; - } - } - - if (name != NULL) { - status = dbp->set_re_source(dbp, name) ; - name = NULL ; - } - - svp = hv_fetch(action, "bfname", 6, FALSE); - if (svp && SvOK(*svp)) { - char * ptr = SvPV(*svp,n_a) ; - name = (char*) n_a ? ptr : NULL ; - } - else - name = NULL ; - - - status = dbp->set_flags(dbp, DB_RENUMBER) ; - - if (flags){ - (void)dbp->set_flags(dbp, flags) ; - } - PrintRecno(info) ; - } - else - croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); - } - - { - int Flags = 0 ; - int status ; - - /* Map 1.x flags to 3.x flags */ - if ((flags & O_CREAT) == O_CREAT) - Flags |= DB_CREATE ; - -#if O_RDONLY == 0 - if (flags == O_RDONLY) -#else - if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) -#endif - Flags |= DB_RDONLY ; - -#ifdef O_TRUNC - if ((flags & O_TRUNC) == O_TRUNC) - Flags |= DB_TRUNCATE ; -#endif - - status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, - Flags, mode) ; - /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ - - if (status == 0) - status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, - 0) ; - /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */ - - if (status) - RETVAL->dbp = NULL ; - - } - - return (RETVAL) ; - -#endif /* Berkeley DB Version > 2 */ - -} /* ParseOpenInfo */ - - -static double -#ifdef CAN_PROTOTYPE -constant(char *name, int arg) -#else -constant(name, arg) -char *name; -int arg; -#endif -{ - 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: - { - __getBerkeleyDBInfo() ; - - DBT_clear(empty) ; - empty.data = &zero ; - empty.size = sizeof(recno_t) ; - } - -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 ; - STRLEN n_a; - - if (items >= 3 && SvOK(ST(2))) - name = (char*) SvPV(ST(2), n_a) ; - - if (items == 6) - sv = ST(5) ; - - RETVAL = ParseOpenInfo(aTHX_ 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) ; -#ifdef DBM_FILTERING - if (db->filter_fetch_key) - SvREFCNT_dec(db->filter_fetch_key) ; - if (db->filter_store_key) - SvREFCNT_dec(db->filter_store_key) ; - if (db->filter_fetch_value) - SvREFCNT_dec(db->filter_fetch_value) ; - if (db->filter_store_value) - SvREFCNT_dec(db->filter_store_value) ; -#endif /* DBM_FILTERING */ - 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_clear(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_clear(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 ; - - DBT_clear(key) ; - DBT_clear(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 ; - - DBT_clear(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 ; - STRLEN n_a; - - DBT_clear(key) ; - DBT_clear(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), n_a) ; - value.size = n_a ; - 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 ; - - DBT_clear(key) ; - DBT_clear(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 ; - - DBT_clear(key) ; - DBT_clear(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 ; - DBT value ; - DB * Db = db->dbp ; - int i ; - STRLEN n_a; - int keyval ; - - DBT_flags(key) ; - DBT_flags(value) ; - CurrentDB = db ; - /* Set the Cursor to the Last element */ - RETVAL = do_SEQ(db, key, value, R_LAST) ; -#ifndef DB_VERSION_MAJOR - if (RETVAL >= 0) -#endif - { - if (RETVAL == 0) - keyval = *(int*)key.data ; - else - keyval = 0 ; - for (i = 1 ; i < items ; ++i) - { - value.data = SvPV(ST(i), n_a) ; - value.size = n_a ; - ++ keyval ; - key.data = &keyval ; - key.size = sizeof(int) ; - RETVAL = (Db->put)(Db, TXN &key, &value, 0) ; - if (RETVAL != 0) - break; - } - } - } - OUTPUT: - RETVAL - -I32 -length(db) - DB_File db - ALIAS: FETCHSIZE = 1 - CODE: - CurrentDB = db ; - RETVAL = GetArrayLength(aTHX_ 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_clear(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 (flagSet(flags, R_IAFTER) || flagSet(flags, 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_clear(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 - -#ifdef DBM_FILTERING - -#define setFilter(type) \ - { \ - if (db->type) \ - RETVAL = sv_mortalcopy(db->type) ; \ - ST(0) = RETVAL ; \ - if (db->type && (code == &PL_sv_undef)) { \ - SvREFCNT_dec(db->type) ; \ - db->type = NULL ; \ - } \ - else if (code) { \ - if (db->type) \ - sv_setsv(db->type, code) ; \ - else \ - db->type = newSVsv(code) ; \ - } \ - } - - -SV * -filter_fetch_key(db, code) - DB_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_key) ; - -SV * -filter_store_key(db, code) - DB_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_key) ; - -SV * -filter_fetch_value(db, code) - DB_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_value) ; - -SV * -filter_store_value(db, code) - DB_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_value) ; - -#endif /* DBM_FILTERING */ diff --git a/contrib/perl5/ext/DB_File/DB_File_BS b/contrib/perl5/ext/DB_File/DB_File_BS deleted file mode 100644 index 9282c49..0000000 --- a/contrib/perl5/ext/DB_File/DB_File_BS +++ /dev/null @@ -1,6 +0,0 @@ -# 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 deleted file mode 100644 index 0414160..0000000 --- a/contrib/perl5/ext/DB_File/Makefile.PL +++ /dev/null @@ -1,29 +0,0 @@ -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', - OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', - XSPROTOARG => '-noprototypes', - DEFINE => $OS2 || "", - INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") - ); - -sub MY::postamble { - ' -version$(OBJ_EXT): version.c - -' ; -} - diff --git a/contrib/perl5/ext/DB_File/dbinfo b/contrib/perl5/ext/DB_File/dbinfo deleted file mode 100644 index 5a4df15..0000000 --- a/contrib/perl5/ext/DB_File/dbinfo +++ /dev/null @@ -1,109 +0,0 @@ -#!/usr/local/bin/perl - -# Name: dbinfo -- identify berkeley DB version used to create -# a database file -# -# Author: Paul Marquess <Paul.Marquess@btinternet.com> -# Version: 1.03 -# Date 17th September 2000 -# -# Copyright (c) 1998-2000 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 -> 2.7.7", - 7 => "3.0.x", - 8 => "3.1.x 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 -> 2.7.7", - 6 => "3.0.x", - 7 => "3.1.x or greater", - } - }, - 0x042253 => { - Type => "Queue", - Versions => - { - 1 => "3.0.x", - 2 => "3.1.x", - 3 => "3.2.x 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} ; -$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/hints/dynixptx.pl b/contrib/perl5/ext/DB_File/hints/dynixptx.pl deleted file mode 100644 index bb5ffa5..0000000 --- a/contrib/perl5/ext/DB_File/hints/dynixptx.pl +++ /dev/null @@ -1,3 +0,0 @@ -# Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug - -$self->{LIBS} = ['-lm -lc']; diff --git a/contrib/perl5/ext/DB_File/hints/sco.pl b/contrib/perl5/ext/DB_File/hints/sco.pl deleted file mode 100644 index ff60440..0000000 --- a/contrib/perl5/ext/DB_File/hints/sco.pl +++ /dev/null @@ -1,2 +0,0 @@ -# osr5 needs to explicitly link against libc to pull in some static symbols -$self->{LIBS} = ['-ldb -lc'] if $Config{'osvers'} =~ '3\.2v5\.0\..' ; diff --git a/contrib/perl5/ext/DB_File/typemap b/contrib/perl5/ext/DB_File/typemap deleted file mode 100644 index 55439ee..0000000 --- a/contrib/perl5/ext/DB_File/typemap +++ /dev/null @@ -1,44 +0,0 @@ -# typemap for Perl 5 interface to Berkeley -# -# written by Paul Marquess <Paul.Marquess@btinternet.com> -# last modified 10th December 2000 -# version 1.74 -# -#################################### DB SECTION -# -# - -u_int T_U_INT -DB_File T_PTROBJ -DBT T_dbtdatum -DBTKEY T_dbtkeydatum - -INPUT -T_dbtkeydatum - ckFilter($arg, filter_store_key, \"filter_store_key\"); - DBT_clear($var) ; - if (db->type != DB_RECNO) { - $var.data = SvPV($arg, PL_na); - $var.size = (int)PL_na; - } - else { - Value = GetRecnoKey(aTHX_ db, SvIV($arg)) ; - $var.data = & Value; - $var.size = (int)sizeof(recno_t); - } -T_dbtdatum - ckFilter($arg, filter_store_value, \"filter_store_value\"); - DBT_clear($var) ; - if (SvOK($arg)) { - $var.data = SvPV($arg, PL_na); - $var.size = (int)PL_na; - } - -OUTPUT - -T_dbtkeydatum - OutputKey($arg, $var) -T_dbtdatum - OutputValue($arg, $var) -T_PTROBJ - sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/contrib/perl5/ext/DB_File/version.c b/contrib/perl5/ext/DB_File/version.c deleted file mode 100644 index 6e55b2e..0000000 --- a/contrib/perl5/ext/DB_File/version.c +++ /dev/null @@ -1,81 +0,0 @@ -/* - - version.c -- Perl 5 interface to Berkeley DB - - written by Paul Marquess <Paul.Marquess@btinternet.com> - last modified 16th January 2000 - version 1.73 - - All comments/suggestions/problems are welcome - - Copyright (c) 1995-2000 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: - 1.71 - Support for Berkeley DB version 3. - Support for Berkeley DB 2/3's backward compatability mode. - 1.72 - No change. - 1.73 - Added support for threading - 1.74 - Added Perl core patch 7801. - - -*/ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include <db.h> - -void -#ifdef CAN_PROTOTYPE -__getBerkeleyDBInfo(void) -#else -__getBerkeleyDBInfo() -#endif -{ -#ifdef dTHX - dTHX; -#endif - SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ; - SV * ver_sv = perl_get_sv("DB_File::db_ver", GV_ADD|GV_ADDMULTI) ; - SV * compat_sv = perl_get_sv("DB_File::db_185_compat", GV_ADD|GV_ADDMULTI) ; - -#ifdef DB_VERSION_MAJOR - int Major, Minor, Patch ; - - (void)db_version(&Major, &Minor, &Patch) ; - - /* Check that the versions of db.h and libdb.a are the same */ - if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR - || Patch != DB_VERSION_PATCH) - croak("\nDB_File needs compatible versions of libdb & db.h\n\tyou have db.h version %d.%d.%d and libdb version %d.%d.%d\n", - DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH, - Major, Minor, Patch) ; - - /* check that libdb is recent enough -- we need 2.3.4 or greater */ - if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4))) - croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", - Major, Minor, Patch) ; - - { - char buffer[40] ; - sprintf(buffer, "%d.%d", Major, Minor) ; - sv_setpv(version_sv, buffer) ; - sprintf(buffer, "%d.%03d%03d", Major, Minor, Patch) ; - sv_setpv(ver_sv, buffer) ; - } - -#else /* ! DB_VERSION_MAJOR */ - sv_setiv(version_sv, 1) ; - sv_setiv(ver_sv, 1) ; -#endif /* ! DB_VERSION_MAJOR */ - -#ifdef COMPAT185 - sv_setiv(compat_sv, 1) ; -#else /* ! COMPAT185 */ - sv_setiv(compat_sv, 0) ; -#endif /* ! COMPAT185 */ - -} |
