Move DB_File from ext/ to cpan/

(Also XS, skipped on Win32 and VMS)

15 files changed, 10063 insertions, 0 deletions

diff --git a/cpan/DB_File/.gitignore b/cpan/DB_File/.gitignore
new file mode 100644
index 0000000000..f1c4edfa6e
--- /dev/null
+++ b/cpan/DB_File/.gitignore
@@ -0,0 +1,3 @@
+!/version.c
+/constants.*
+*.bak
diff --git a/cpan/DB_File/Changes b/cpan/DB_File/Changes
new file mode 100644
index 0000000000..781a8b728f
--- /dev/null
+++ b/cpan/DB_File/Changes
@@ -0,0 +1,549 @@
+
+
+1.820 28 March 2009
+
+   * remove MAN3PODS from Makefile.PL to match core.
+
+1.819 18 February 2009
+
+   * t/db-recno.t fails if run in a path that contains spaces
+     [rt.cpan.org #43288]
+
+1.818 21 January 2009
+
+   * Updated Makefile.PL for Strawberry Perl. 
+     Patch suggested by David Golden.
+
+   * Remove IRIX notes from README. The page referenced doesn't exist
+     anymore.
+
+1.817 27 March 2008
+
+   * Updated dbinfo
+
+   * Applied core patch 32299 - Re-apply change #30562
+
+   * Applied core patch 32208
+
+   * Applied core patch 32884 - use MM->parse_version() in Makefile.PL
+
+   * Applied core patch 32883 -  Silence new warning grep in void context warning
+
+   * Applied core patch 32704 to remove use of PL_na in typemap
+
+   * Applied core patch 30562 to fix a build issue on OSF
+
+1.816 28 October 2007
+
+   * Clarified the warning about building with a different version of
+     Berkeley DB that is used at runtime.
+
+   * Also made the boot version check less strict.
+     [rt.cpan.org #30013]
+
+1.815 4 February 2007
+
+   * A few casting cleanups for building with C++ from Steve Peters.
+
+   * Fixed problem with recno which happened if you changed directory after
+     opening the database. Problem reported by Andrew Pam.
+
+
+1.814 11 November 2005
+
+   * Fix from Dominic Dunlop to tidy up an OS-X specific warning in
+     db-btree.t.
+
+   * Silenced a warning about $DB_File::Error only being used once.
+     Issue spotted by Dominic Dunlop.
+
+1.813 31st October 2005
+
+   * Updates for Berkeley DB 4.4
+
+1.812 9th October 2005
+
+   * Added libscan to Makefile.PL
+
+   * Fixed test failing under windows
+
+1.811 12th March 2005
+
+   * Fixed DBM filter bug in seq
+
+1.810 7th August 2004
+
+   * Fixed db-hash.t for Cygwin
+
+   * Added substr tests to db-hast.t
+
+   * Documented AIX build problem in README.
+
+1.809 20th June 2004
+
+   * Merged core patch 22258
+
+   * Merged core patch 22741
+
+   * Fixed core bug 30237. 
+     Using substr to pass parameters to the low-level Berkeley DB interface
+     causes problems with Perl 5.8.1 or better.
+     typemap fix supplied by Marcus Holland-Moritz.
+
+1.808 22nd December 2003
+
+   * Added extra DBM Filter tests.
+
+   * Fixed a memory leak in ParseOpenInfo, which whould occur if the
+     opening of the database failed. Leak spotted by Adrian Enache.
+
+1.807 1st November 2003
+
+   * Fixed minor typos on pod documetation - reported by Jeremy Mates &
+     Mark Jason Dominus.
+
+   * dbinfo updated to report when a database is encrypted.
+
+1.806 22nd October 2002
+
+   * Fixed problem when trying to build with a multi-threaded perl.
+
+   * Tidied up the recursion detetion code.
+
+   * merged core patch 17844 - missing dTHX declarations.
+
+   * merged core patch 17838 
+
+1.805 1st September 2002
+
+   * Added support to allow DB_File to build with Berkeley DB 4.1.X
+
+   * Tightened up the test harness to test that calls to untie don't generate
+     the "untie attempted while %d inner references still exist" warning.
+
+   * added code to guard against calling the callbacks (compare,hash & prefix) 
+     recursively.
+
+   * pasing undef for the flags and/or mode when opening a database could cause
+     a "Use of uninitialized value in subroutine entry" warning. Now silenced.
+
+   * DBM filter code beefed up to cope with read-only $_.
+
+1.804 2nd June 2002
+
+   * Perl core patch 14939 added a new warning to "splice". This broke the
+     db-recno test harness. Fixed.
+
+   * merged core patches 16502 & 16540.
+
+1.803 1st March 2002
+
+   * Fixed a problem with db-btree.t where it complained about an "our"
+     variable redeclaation.
+
+   * FETCH, STORE & DELETE don't map the flags parameter into the
+     equivalent Berkeley DB function anymore.
+
+1.802 6th January 2002
+
+   * The message about some test failing in db-recno.t had the wrong test
+     numbers. Fixed.
+
+   * merged core patch 13942.
+
+1.801 26th November 2001
+
+   * Fixed typo in Makefile.PL
+
+   * Added "clean" attribute to Makefile.PL
+ 
+1.800 23rd November 2001
+
+   * use pport.h for perl backward compatability code.
+
+   * use new  ExtUtils::Constant module to generate XS constants.
+
+   * upgrade Makefile.PL upgrade/downgrade code to toggle "our" with
+     "use vars"
+
+1.79 22nd October 2001
+
+   * Added a "local $SIG{__DIE__}" inside the eval that checks for
+     the presence of XSLoader s suggested by Andrew Hryckowin.
+
+   * merged core patch 12277.
+
+   * Changed NEXTKEY to not initialise the input key. It isn't used anyway.
+
+1.79 22nd October 2001
+
+   * Fixed test harness for cygwin
+
+1.78 30th July 2001
+
+   * the test in Makefile.PL for AIX used -plthreads. Should have been
+     -lpthreads
+
+   * merged Core patches 
+        10372, 10335, 10372, 10534, 10549, 10643, 11051, 11194, 11432
+
+   * added documentation patch regarding duplicate keys from Andrew Johnson
+
+
+1.77 26th April 2001
+
+   * AIX is reported to need -lpthreads, so Makefile.PL now checks for
+     AIX and adds it to the link options.
+
+   * Minor documentation updates.
+
+   * Merged Core patch 9176
+
+   * Added a patch from Edward Avis that adds support for splice with
+     recno databases.
+
+   * Modified Makefile.PL to only enable the warnings pragma if using perl
+     5.6.1 or better.    
+
+1.76 15th January 2001
+
+   * Added instructions for using LD_PRELOAD to get Berkeley DB 2.x to work
+     with DB_File on Linux. Thanks to Norbert Bollow for sending details of
+     this approach.
+
+
+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.
+
+
+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.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.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.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.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.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.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.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.66 15th March 1999
+
+   * Added DBM Filter code
+
+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.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.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.62 30th November 1998
+
+   Added hints/dynixptx.pl.
+   Fixed typemap -- 1.61 used PL_na instead of na
+
+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.60
+   Changed the test to check for full tied array support
+
+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.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.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.56
+   Documented the Solaris 2.5 mutex bug
+
+1.55
+   Merged 1.16 changes.
+
+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.53
+
+   Added DB_RENUMBER to flags for recno.
+
+1.52
+
+   Patch from Nick Ing-Simmons now allows DB_File to build on NT.
+   Merged 1.15 patch.
+
+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.50
+
+    DB_File can now build with either DB 1.x or 2.x, but not both at
+    the same time.
+
+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.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.14
+
+    Made it illegal to tie an associative array to a RECNO database and
+    an ordinary array to a HASH or BTREE database.
+
+1.13
+
+    Minor changes to DB_FIle.xs and DB_File.pm
+
+1.12
+
+    Documented the incompatibility with version 2 of Berkeley DB.
+
+1.11
+
+    Documented the untie gotcha.
+
+1.10
+
+    Fixed fd method so that it still returns -1 for in-memory files
+    when db 1.86 is used.
+
+1.09
+
+    Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and
+    DB_File::BTREEINFO.
+
+    Changed default mode to 0666.
+
+1.08
+
+    Documented operation of bval.
+
+1.07
+
+    Fixed bug with RECNO, where bval wasn't defaulting to "\n".
+
+1.06
+
+    Minor namespace cleanup: Localized PrintBtree.
+
+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.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.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.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.01
+
+    Fixed a core dump problem with SunOS.
+
+    The return value from TIEHASH wasn't set to NULL when dbopen
+    returned an error.
+
+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.
+
+0.3
+
+    Added prototype support for multiple btree compare callbacks.
+
+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.1
+
+    First Release.
+
diff --git a/cpan/DB_File/DB_File.pm b/cpan/DB_File/DB_File.pm
new file mode 100644
index 0000000000..86d0b19888
--- /dev/null
+++ b/cpan/DB_File/DB_File.pm
@@ -0,0 +1,2299 @@
+# DB_File.pm -- Perl 5 interface to Berkeley DB 
+#
+# written by Paul Marquess (pmqs@cpan.org)
+# last modified 28th October 2007
+# version 1.818
+#
+#     Copyright (c) 1995-2009 Paul Marquess. All rights reserved.
+#     This program is free software; you can redistribute it and/or
+#     modify it under the same terms as Perl itself.
+
+
+package DB_File::HASHINFO ;
+
+require 5.00404;
+
+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 => { 
+		       	bsize	  => 1,
+			ffactor	  => 1,
+			nelem	  => 1,
+			cachesize => 1,
+			hash	  => 2,
+			lorder	  => 1,
+		     }, 
+	    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 ;
+
+    my $type = $self->{VALID}{$key};
+
+    if ( $type )
+    {
+    	croak "Key '$key' not associated with a code reference" 
+	    if $type == 2 && !ref $value && ref $value ne 'CODE';
+        $self->{GOT}{$key} = $value ;
+        return ;
+    }
+    
+    my $pkg = ref $self ;
+    croak "${pkg}::STORE - Unknown element '$key'" ;
+}
+
+sub DELETE 
+{
+    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 => { 
+		      	flags	   => 1,
+			cachesize  => 1,
+			maxkeypage => 1,
+			minkeypage => 1,
+			psize	   => 1,
+			compare	   => 2,
+			prefix	   => 2,
+			lorder	   => 1,
+	    	     },
+	    GOT   => {},
+          }, $pkg ;
+}
+
+
+package DB_File ;
+
+use warnings;
+use strict;
+our ($VERSION, @ISA, @EXPORT, $AUTOLOAD, $DB_BTREE, $DB_HASH, $DB_RECNO);
+our ($db_version, $use_XSLoader, $splice_end_array, $Error);
+use Carp;
+
+
+$VERSION = "1.820" ;
+$VERSION = eval $VERSION; # needed for dev releases
+
+{
+    local $SIG{__WARN__} = sub {$splice_end_array = "@_";};
+    my @a =(1); splice(@a, 3);
+    $splice_end_array = 
+        ($splice_end_array =~ /^splice\(\) offset past end of array at /);
+}      
+
+#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
+$DB_BTREE = new DB_File::BTREEINFO ;
+$DB_HASH  = new DB_File::HASHINFO ;
+$DB_RECNO = new DB_File::RECNOINFO ;
+
+require Tie::Hash;
+require Exporter;
+use AutoLoader;
+BEGIN {
+    $use_XSLoader = 1 ;
+    { local $SIG{__DIE__} ; 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 ($error, $val) = constant($constname);
+    Carp::croak $error if $error;
+    no strict 'refs';
+    *{$AUTOLOAD} = sub { $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/ ) ;
+
+    use File::Spec;
+    $arg[1] = File::Spec->rel2abs($arg[1]) 
+        if defined $arg[1] ;
+
+    $arg[4] = tied %{ $arg[4] } 
+	if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ;
+
+    $arg[2] = O_CREAT()|O_RDWR() if @arg >=3 && ! defined $arg[2];
+    $arg[3] = 0666               if @arg >=4 && ! defined $arg[3];
+
+    # make recno in Berkeley DB version 2 (or better) work like 
+    # recno in version 1.
+    if ($db_version >= 4 and ! $tieHASH) {
+        $arg[2] |= O_CREAT();
+    }
+
+    if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and 
+	$arg[1] and ! -e $arg[1]) {
+	open(FH, ">$arg[1]") or return undef ;
+	close FH ;
+	chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ;
+    }
+
+    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 SPLICE
+{
+    my $self = shift;
+    my $offset = shift;
+    if (not defined $offset) {
+	warnings::warnif('uninitialized', 'Use of uninitialized value in splice');
+	$offset = 0;
+    }
+
+    my $length = @_ ? shift : 0;
+    # Carping about definedness comes _after_ the OFFSET sanity check.
+    # This is so we get the same error messages as Perl's splice().
+    # 
+
+    my @list = @_;
+
+    my $size = $self->FETCHSIZE();
+    
+    # 'If OFFSET is negative then it start that far from the end of
+    # the array.'
+    # 
+    if ($offset < 0) {
+	my $new_offset = $size + $offset;
+	if ($new_offset < 0) {
+	    die "Modification of non-creatable array value attempted, "
+	      . "subscript $offset";
+	}
+	$offset = $new_offset;
+    }
+
+    if (not defined $length) {
+	warnings::warnif('uninitialized', 'Use of uninitialized value in splice');
+	$length = 0;
+    }
+
+    if ($offset > $size) {
+ 	$offset = $size;
+	warnings::warnif('misc', 'splice() offset past end of array')
+            if $splice_end_array;
+    }
+
+    # 'If LENGTH is omitted, removes everything from OFFSET onward.'
+    if (not defined $length) {
+	$length = $size - $offset;
+    }
+
+    # 'If LENGTH is negative, leave that many elements off the end of
+    # the array.'
+    # 
+    if ($length < 0) {
+	$length = $size - $offset + $length;
+
+	if ($length < 0) {
+	    # The user must have specified a length bigger than the
+	    # length of the array passed in.  But perl's splice()
+	    # doesn't catch this, it just behaves as for length=0.
+	    # 
+	    $length = 0;
+	}
+    }
+
+    if ($length > $size - $offset) {
+	$length = $size - $offset;
+    }
+
+    # $num_elems holds the current number of elements in the database.
+    my $num_elems = $size;
+
+    # 'Removes the elements designated by OFFSET and LENGTH from an
+    # array,'...
+    # 
+    my @removed = ();
+    foreach (0 .. $length - 1) {
+	my $old;
+	my $status = $self->get($offset, $old);
+	if ($status != 0) {
+	    my $msg = "error from Berkeley DB on get($offset, \$old)";
+	    if ($status == 1) {
+		$msg .= ' (no such element?)';
+	    }
+	    else {
+		$msg .= ": error status $status";
+		if (defined $! and $! ne '') {
+		    $msg .= ", message $!";
+		}
+	    }
+	    die $msg;
+	}
+	push @removed, $old;
+
+	$status = $self->del($offset);
+	if ($status != 0) {
+	    my $msg = "error from Berkeley DB on del($offset)";
+	    if ($status == 1) {
+		$msg .= ' (no such element?)';
+	    }
+	    else {
+		$msg .= ": error status $status";
+		if (defined $! and $! ne '') {
+		    $msg .= ", message $!";
+		}
+	    }
+	    die $msg;
+	}
+
+	-- $num_elems;
+    }
+
+    # ...'and replaces them with the elements of LIST, if any.'
+    my $pos = $offset;
+    while (defined (my $elem = shift @list)) {
+	my $old_pos = $pos;
+	my $status;
+	if ($pos >= $num_elems) {
+	    $status = $self->put($pos, $elem);
+	}
+	else {
+	    $status = $self->put($pos, $elem, $self->R_IBEFORE);
+	}
+
+	if ($status != 0) {
+	    my $msg = "error from Berkeley DB on put($pos, $elem, ...)";
+	    if ($status == 1) {
+		$msg .= ' (no such element?)';
+	    }
+	    else {
+		$msg .= ", error status $status";
+		if (defined $! and $! ne '') {
+		    $msg .= ", message $!";
+		}
+	    }
+	    die $msg;
+	}
+
+	die "pos unexpectedly changed from $old_pos to $pos with R_IBEFORE"
+	  if $old_pos != $pos;
+
+	++ $pos;
+	++ $num_elems;
+    }
+
+    if (wantarray) {
+	# 'In list context, returns the elements removed from the
+	# array.'
+	# 
+	return @removed;
+    }
+    elsif (defined wantarray and not wantarray) {
+	# 'In scalar context, returns the last element removed, or
+	# undef if no elements are removed.'
+	# 
+	if (@removed) {
+	    my $last = pop @removed;
+	    return "$last";
+	}
+	else {
+	    return undef;
+	}
+    }
+    elsif (not defined wantarray) {
+	# Void context
+    }
+    else { die }
+}
+sub ::DB_File::splice { &SPLICE }
+
+sub find_dup
+{
+    croak "Usage: \$db->find_dup(key,value)\n"
+        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);
+ @r = $X->splice(offset, length, elements);
+
+ # 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 greater>).
+It is assumed that you have a copy of the Berkeley DB manual pages at
+hand when reading this documentation. The interface defined here
+mirrors the Berkeley DB interface closely.
+
+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 greater
+
+Although B<DB_File> is intended to be used with Berkeley DB version 1,
+it can also be used with version 2, 3 or 4. In this case the interface is
+limited to the functionality provided by Berkeley DB 1.x. Anywhere the
+version 2 or greater interface differs, B<DB_File> arranges for it to work
+like version 1. This feature allows B<DB_File> scripts that were built
+with version 1 to be migrated to version 2 or greater without any changes.
+
+If you want to make use of the new features available in Berkeley DB
+2.x or greater, use the Perl module B<BerkeleyDB> instead.
+
+B<Note:> The database file format has changed multiple times in Berkeley
+DB version 2, 3 and 4. If you cannot recreate your databases, you
+must dump any existing databases with either the C<db_dump> or the
+C<db_dump185> utility that comes with Berkeley DB.
+Once you have rebuilt DB_File to use Berkeley DB version 2 or greater,
+your databases can be recreated using C<db_load>. Refer to the Berkeley DB
+documentation for further details.
+
+Please read L<"COPYRIGHT"> before using version 2.x or greater 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 ;
+    our (%h, $k, $v) ;
+
+    unlink "fruit" ;
+    tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0666, $DB_HASH 
+        or die "Cannot open file 'fruit': $!\n";
+
+    # Add a few key/value pairs to the file
+    $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, 0666, $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.
+
+=item 3
+
+Duplicate keys are entirely defined by the comparison function.
+In the case-insensitive example above, the keys: 'KEY' and 'key'
+would be considered duplicates, and assigning to the second one
+would overwrite the first. If duplicates are allowed for (with the
+R_DUP flag discussed below), only a single copy of duplicate keys
+is stored in the database --- so (again with example above) assigning
+three values to the keys: 'KEY', 'Key', and 'key' would leave just
+the first key: 'KEY' in the database with three values. For some
+situations this results in information loss, so care should be taken
+to provide fully qualified comparison functions when necessary.
+For example, the above comparison routine could be modified to
+additionally compare case-sensitively if two keys are equal in the
+case insensitive comparison:
+
+    sub compare {
+        my($key1, $key2) = @_;
+        lc $key1 cmp lc $key2 ||
+        $key1 cmp $key2;
+    }
+
+And now you will only have duplicates when the keys themselves
+are truly the same. (note: in versions of the db library prior to
+about November 1996, such duplicate keys were retained so it was
+possible to recover the original keys in sets of keys that
+compared as equal).
+
+
+=back 
+
+=head2 Handling Duplicate Keys 
+
+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 ;
+
+    my ($filename, %h) ;
+
+    $filename = "tree" ;
+    unlink $filename ;
+
+    # Enable duplicate records
+    $DB_BTREE->{'flags'} = R_DUP ;
+
+    tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE 
+	or die "Cannot open $filename: $!\n";
+
+    # 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 ;
+
+    my ($filename, $x, %h, $status, $key, $value) ;
+
+    $filename = "tree" ;
+    unlink $filename ;
+
+    # Enable duplicate records
+    $DB_BTREE->{'flags'} = R_DUP ;
+
+    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE 
+	or die "Cannot open $filename: $!\n";
+
+    # Add some key/value pairs to the file
+    $h{'Wall'} = 'Larry' ;
+    $h{'Wall'} = 'Brick' ; # Note the duplicate key
+    $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
+    $h{'Smith'} = 'John' ;
+    $h{'mouse'} = 'mickey' ;
+
+    # iterate through the btree using seq
+    # and print each key/value pair.
+    $key = $value = 0 ;
+    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 ;
+
+    my ($filename, $x, %h) ;
+
+    $filename = "tree" ;
+
+    # Enable duplicate records
+    $DB_BTREE->{'flags'} = R_DUP ;
+
+    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE 
+	or die "Cannot open $filename: $!\n";
+
+    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 ;
+
+    my ($filename, $x, %h, $found) ;
+
+    $filename = "tree" ;
+
+    # Enable duplicate records
+    $DB_BTREE->{'flags'} = R_DUP ;
+
+    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE 
+	or die "Cannot open $filename: $!\n";
+
+    $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; 
+    print "Larry Wall is $found there\n" ;
+
+    $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; 
+    print "Harry Wall is $found there\n" ;
+
+    undef $x ;
+    untie %h ;
+
+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 ;
+
+    my ($filename, $x, %h, $found) ;
+
+    $filename = "tree" ;
+
+    # Enable duplicate records
+    $DB_BTREE->{'flags'} = R_DUP ;
+
+    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE 
+	or die "Cannot open $filename: $!\n";
+
+    $x->del_dup("Wall", "Larry") ;
+
+    $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; 
+    print "Larry Wall is $found there\n" ;
+
+    undef $x ;
+    untie %h ;
+
+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 ;
+
+    my ($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, 0666, $DB_BTREE
+        or die "Cannot open $filename: $!\n";
+
+    # Add some key/value pairs to the file
+    $h{'mouse'} = 'mickey' ;
+    $h{'Wall'} = 'Larry' ;
+    $h{'Walls'} = 'Brick' ; 
+    $h{'Smith'} = 'John' ;
+
+
+    $key = $value = 0 ;
+    print "IN ORDER\n" ;
+    for ($st = $x->seq($key, $value, R_FIRST) ;
+	 $st == 0 ;
+         $st = $x->seq($key, $value, R_NEXT) )
+
+      {  print "$key	-> $value\n" }
+
+    print "\nPARTIAL MATCH\n" ;
+
+    match "Wa" ;
+    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.
+
+Also note that the bval option only allows you to specify a single byte
+as a delimiter.
+
+=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, 0666, $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.
+
+=item B<$X-E<gt>splice(offset, length, elements);>
+
+Returns a splice of 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 ;
+    my (@h, $H, $file, $i) ;
+    use DB_File ;
+    use Fcntl ;
+
+    $file = "text" ;
+
+    unlink $file ;
+
+    $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0666, $DB_RECNO 
+        or die "Cannot open file $file: $!\n" ;
+
+    # first create a text file to play with
+    $h[0] = "zero" ;
+    $h[1] = "one" ;
+    $h[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 = "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} = "something" ;
+
+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 = "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', 'foo.db', O_CREAT|O_RDWR, 0644)
+        || die "dbcreat 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 ;
+
+    my ($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 ;
+    my %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<perlmodlib/CPAN> for details), in the directory
+F<modules/by-module/DB_File>.
+
+This version of B<DB_File> will work with either version 1.x, 2.x or
+3.x of Berkeley DB, but is limited to the functionality provided by
+version 1.
+
+The official web site for Berkeley DB is F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>.
+All versions of Berkeley DB are available there.
+
+Alternatively, Berkeley DB version 1 is available at your nearest CPAN
+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-2007 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.oracle.com/technology/products/berkeley-db/db/index.html>) 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>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>,
+L<perldbmfilter>
+
+=head1 AUTHOR
+
+The DB_File interface was written by Paul Marquess
+E<lt>pmqs@cpan.orgE<gt>.
+
+=cut
diff --git a/cpan/DB_File/DB_File.xs b/cpan/DB_File/DB_File.xs
new file mode 100644
index 0000000000..afd0f63a15
--- /dev/null
+++ b/cpan/DB_File/DB_File.xs
@@ -0,0 +1,1995 @@
+/* 
+
+ DB_File.xs -- Perl 5 interface to Berkeley DB 
+
+ written by Paul Marquess <pmqs@cpan.org>
+ last modified 4th February 2007
+ version 1.818
+
+ All comments/suggestions/problems are welcome
+
+     Copyright (c) 1995-2009 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.
+        1.76 -  No change to DB_File.xs
+        1.77 -  Tidied up a few types used in calling newSVpvn.
+        1.78 -  Core patch 10335, 10372, 10534, 10549, 11051 included.
+        1.79 -  NEXTKEY ignores the input key.
+                Added lots of casts
+        1.800 - Moved backward compatability code into ppport.h.
+                Use the new constants code.
+        1.801 - No change to DB_File.xs
+        1.802 - No change to DB_File.xs
+        1.803 - FETCH, STORE & DELETE don't map the flags parameter
+                into the equivalent Berkeley DB function anymore.
+        1.804 - no change.
+        1.805 - recursion detection added to the callbacks
+                Support for 4.1.X added.
+                Filter code can now cope with read-only $_
+        1.806 - recursion detection beefed up.
+        1.807 - no change
+        1.808 - leak fixed in ParseOpenInfo
+        1.809 - no change
+        1.810 - no change
+        1.811 - no change
+        1.812 - no change
+        1.813 - no change
+        1.814 - no change
+        1.814 - C++ casting fixes
+
+*/
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"  
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef _NOT_CORE
+#  include "ppport.h"
+#endif
+
+/* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and
+   DB_VERSION_PATCH_CFG here so that Configure pulls them all in. */
+
+/* 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. */
+
+/* #if DB_VERSION_MAJOR_CFG < 2  */
+#ifndef DB_VERSION_MAJOR
+#    undef __attribute__
+#endif
+
+#ifdef COMPAT185
+#    include <db_185.h>
+#else
+#    include <db.h>
+#endif
+
+/* Wall starts with 5.7.x */
+
+#if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 7)
+
+/* Since we dropped the gccish definition of __attribute__ we will want
+ * to redefine dNOOP, however (so that dTHX continues to work).  Yes,
+ * all this means that we can't do attribute checking on the DB_File,
+ * boo, hiss. */
+#  ifndef DB_VERSION_MAJOR
+
+#    undef  dNOOP
+#    define dNOOP extern int Perl___notused
+
+    /* Ditto for dXSARGS. */
+#    undef  dXSARGS
+#    define dXSARGS				\
+	dSP; dMARK;			\
+	I32 ax = mark - PL_stack_base + 1;	\
+	I32 items = sp - mark
+
+#  endif
+
+/* avoid -Wall; DB_File xsubs never make use of `ix' setup for ALIASes */
+#  undef dXSI32
+#  define dXSI32 dNOOP
+
+#endif /* Perl >= 5.7 */
+
+#include <fcntl.h> 
+
+/* #define TRACE */
+
+#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
+
+#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 3)
+#    define AT_LEAST_DB_3_3
+#endif
+
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1)
+#    define AT_LEAST_DB_4_1
+#endif
+
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 3)
+#    define AT_LEAST_DB_4_3
+#endif
+
+#ifdef AT_LEAST_DB_3_3
+#   define WANT_ERROR
+#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, 0)
+#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, 0)
+#define db_FETCH(db, key, flags)        ((db->dbp)->get)(db->dbp, TXN &key, &value, 0)
+
+#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->aborted && ( 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->aborted && ((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 ;
+	bool	in_compare ;
+	SV *	prefix ;
+	bool	in_prefix ;
+	SV *	hash ;
+	bool	in_hash ;
+	bool	aborted ;
+	int	in_memory ;
+#ifdef BERKELEY_DB_1_OR_2
+	INFO 	info ;
+#endif	
+#ifdef DB_VERSION_MAJOR
+	DBC *	cursor ;
+#endif
+	SV *    filter_fetch_key ;
+	SV *    filter_store_key ;
+	SV *    filter_fetch_value ;
+	SV *    filter_store_value ;
+	int     filtering ;
+
+	} DB_File_type;
+
+typedef DB_File_type * DB_File ;
+typedef DBT DBTKEY ;
+
+#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (const char *)""), s)
+
+#define OutputValue(arg, name)  					\
+	{ if (RETVAL == 0) {						\
+	      SvGETMAGIC(arg) ;          				\
+	      my_sv_setpvn(arg, (const char *)name.data, name.size) ;			\
+	      TAINT;                                       		\
+	      SvTAINTED_on(arg);                                       	\
+	      SvUTF8_off(arg);                                       	\
+	      DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; 	\
+	  }								\
+	}
+
+#define OutputKey(arg, name)	 					\
+	{ if (RETVAL == 0) 						\
+	  { 								\
+		SvGETMAGIC(arg) ;          				\
+		if (db->type != DB_RECNO) {				\
+		    my_sv_setpvn(arg, (const char *)name.data, name.size); 		\
+		}							\
+		else 							\
+		    sv_setiv(arg, (I32)*(I32*)name.data - 1); 		\
+	      TAINT;                                       		\
+	      SvTAINTED_on(arg);                                       	\
+	      SvUTF8_off(arg);                                       	\
+	      DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; 	\
+	  } 								\
+	}
+
+#define my_SvUV32(sv) ((u_int32_t)SvUV(sv))
+
+#ifdef CAN_PROTOTYPE
+extern void __getBerkeleyDBInfo(void);
+#endif
+
+/* Internal Global Data */
+
+#define MY_CXT_KEY "DB_File::_guts" XS_VERSION
+
+typedef struct {
+    recno_t	x_Value; 
+    recno_t	x_zero;
+    DB_File	x_CurrentDB;
+    DBTKEY	x_empty;
+} my_cxt_t;
+
+START_MY_CXT
+
+#define Value		(MY_CXT.x_Value)
+#define zero		(MY_CXT.x_zero)
+#define CurrentDB	(MY_CXT.x_CurrentDB)
+#define empty		(MY_CXT.x_empty)
+
+#define ERR_BUFF "DB_File::Error"
+
+#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 void
+tidyUp(DB_File db)
+{
+    db->aborted = TRUE ;
+}
+
+
+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 ;
+    dMY_CXT ;
+    void * data1, * data2 ;
+    int retval ;
+    int count ;
+    
+
+    if (CurrentDB->in_compare) {
+        tidyUp(CurrentDB);
+        croak ("DB_File btree_compare: recursion detected\n") ;
+    }
+
+    data1 = (char *) key1->data ;
+    data2 = (char *) 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;
+    SAVESPTR(CurrentDB);
+    CurrentDB->in_compare = FALSE;
+    SAVEINT(CurrentDB->in_compare);
+    CurrentDB->in_compare = TRUE;
+
+    PUSHMARK(SP) ;
+    EXTEND(SP,2) ;
+    PUSHs(sv_2mortal(newSVpvn((const char*)data1,key1->size)));
+    PUSHs(sv_2mortal(newSVpvn((const char*)data2,key2->size)));
+    PUTBACK ;
+
+    count = perl_call_sv(CurrentDB->compare, G_SCALAR); 
+
+    SPAGAIN ;
+
+    if (count != 1){
+        tidyUp(CurrentDB);
+        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 ;
+    dMY_CXT ;
+    char * data1, * data2 ;
+    int retval ;
+    int count ;
+    
+    if (CurrentDB->in_prefix){
+        tidyUp(CurrentDB);
+        croak ("DB_File btree_prefix: recursion detected\n") ;
+    }
+
+    data1 = (char *) key1->data ;
+    data2 = (char *) 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;
+    SAVESPTR(CurrentDB);
+    CurrentDB->in_prefix = FALSE;
+    SAVEINT(CurrentDB->in_prefix);
+    CurrentDB->in_prefix = TRUE;
+
+    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){
+        tidyUp(CurrentDB);
+        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 ;
+    dMY_CXT;
+    int retval = 0;
+    int count ;
+
+    if (CurrentDB->in_hash){
+        tidyUp(CurrentDB);
+        croak ("DB_File hash callback: recursion detected\n") ;
+    }
+
+#ifndef newSVpvn
+    if (size == 0)
+        data = "" ;
+#endif	
+
+     /* DGH - Next two lines added to fix corrupted stack problem */
+    ENTER ;
+    SAVETMPS;
+    SAVESPTR(CurrentDB);
+    CurrentDB->in_hash = FALSE;
+    SAVEINT(CurrentDB->in_hash);
+    CurrentDB->in_hash = TRUE;
+
+    PUSHMARK(SP) ;
+
+
+    XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
+    PUTBACK ;
+
+    count = perl_call_sv(CurrentDB->hash, G_SCALAR); 
+
+    SPAGAIN ;
+
+    if (count != 1){
+        tidyUp(CurrentDB);
+        croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
+    }
+
+    retval = POPi ;
+
+    PUTBACK ;
+    FREETMPS ;
+    LEAVE ;
+
+    return (retval) ;
+}
+
+#ifdef WANT_ERROR
+
+static void
+#ifdef AT_LEAST_DB_4_3
+db_errcall_cb(const DB_ENV* dbenv, const char * db_errpfx, const char * buffer)
+#else
+db_errcall_cb(const char * db_errpfx, char * buffer)
+#endif
+{
+#ifdef dTHX
+    dTHX;
+#endif    
+    SV * sv = perl_get_sv(ERR_BUFF, FALSE) ;
+    if (sv) {
+        if (db_errpfx)
+            sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ;
+        else
+            sv_setpv(sv, buffer) ;
+    }
+} 
+#endif
+
+#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    = %lu\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) {
+            tidyUp(db);
+	    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;
+    dMY_CXT;
+
+#ifdef TRACE    
+    printf("In ParseOpenInfo name=[%s] flags=[%d] mode=[%d] SV NULL=[%d]\n", 
+		    name, flags, mode, sv == NULL) ;  
+#endif
+    Zero(RETVAL, 1, DB_File_type) ;
+
+    /* Default to HASH */
+    RETVAL->filtering = 0 ;
+    RETVAL->filter_fetch_key = RETVAL->filter_store_key = 
+    RETVAL->filter_fetch_value = RETVAL->filter_store_value =
+    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, (DB_INFO*)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 ;
+    dMY_CXT;
+
+/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ;  */
+    Zero(RETVAL, 1, DB_File_type) ;
+
+    /* Default to HASH */
+    RETVAL->filtering = 0 ;
+    RETVAL->filter_fetch_key = RETVAL->filter_store_key = 
+    RETVAL->filter_fetch_value = RETVAL->filter_store_value =
+    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 ;
+
+#ifdef WANT_ERROR
+	    RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ;
+#endif
+    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, my_SvUV32(*svp)) ;
+         
+           svp = hv_fetch(action, "nelem", 5, FALSE);
+	   if (svp)
+               (void)dbp->set_h_nelem(dbp, my_SvUV32(*svp)) ;
+         
+           svp = hv_fetch(action, "bsize", 5, FALSE);
+	   if (svp)
+               (void)dbp->set_pagesize(dbp, my_SvUV32(*svp));
+           
+           svp = hv_fetch(action, "cachesize", 9, FALSE);
+	   if (svp)
+               (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
+         
+           svp = hv_fetch(action, "lorder", 6, FALSE);
+	   if (svp)
+               (void)dbp->set_lorder(dbp, (int)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, my_SvUV32(*svp)) ;
+   
+           svp = hv_fetch(action, "cachesize", 9, FALSE);
+	   if (svp)
+               (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
+         
+           svp = hv_fetch(action, "psize", 5, FALSE);
+	   if (svp)
+               (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
+         
+           svp = hv_fetch(action, "lorder", 6, FALSE);
+	   if (svp)
+               (void)dbp->set_lorder(dbp, (int)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, my_SvUV32(*svp), 0) ;
+	   }
+         
+           svp = hv_fetch(action, "psize", 5, FALSE);
+	   if (svp) {
+               status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
+	    }
+         
+           svp = hv_fetch(action, "lorder", 6, FALSE);
+	   if (svp) {
+               status = dbp->set_lorder(dbp, (int)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 = (int)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 =  my_SvUV32(*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, (u_int32_t)DB_RENUMBER) ;
+         
+		if (flags){
+	            (void)dbp->set_flags(dbp, (u_int32_t)flags) ;
+		}
+            PrintRecno(info) ;
+        }
+        else
+            croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
+    }
+
+    {
+        u_int32_t 	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
+
+#ifdef AT_LEAST_DB_4_4
+        /* need this for recno */
+        if ((flags & O_TRUNC) == O_TRUNC)
+            Flags |= DB_CREATE ;
+#endif
+
+#ifdef AT_LEAST_DB_4_1
+        status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type, 
+	    			Flags, mode) ; 
+#else
+        status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, 
+	    			Flags, mode) ; 
+#endif
+	/* 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 */
+
+
+#include "constants.h"   
+
+MODULE = DB_File	PACKAGE = DB_File	PREFIX = db_
+
+INCLUDE: constants.xs
+
+BOOT:
+  {
+#ifdef dTHX
+    dTHX;
+#endif    
+#ifdef WANT_ERROR
+    SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; 
+#endif
+    MY_CXT_INIT;
+    __getBerkeleyDBInfo() ;
+ 
+    DBT_clear(empty) ; 
+    empty.data = &zero ;
+    empty.size =  sizeof(recno_t) ;
+  }
+
+
+
+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) {
+	        Safefree(RETVAL);
+	        RETVAL = NULL ;
+	    }
+	}
+	OUTPUT:	
+	    RETVAL
+
+int
+db_DESTROY(db)
+	DB_File		db
+	PREINIT:
+	  dMY_CXT;
+	INIT:
+	  CurrentDB = db ;
+	  Trace(("DESTROY %p\n", db));
+	CLEANUP:
+	  Trace(("DESTROY %p done\n", db));
+	  if (db->hash)
+	    SvREFCNT_dec(db->hash) ;
+	  if (db->compare)
+	    SvREFCNT_dec(db->compare) ;
+	  if (db->prefix)
+	    SvREFCNT_dec(db->prefix) ;
+	  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) ;
+	  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
+	PREINIT:
+	  dMY_CXT;
+	INIT:
+	  CurrentDB = db ;
+
+
+int
+db_EXISTS(db, key)
+	DB_File		db
+	DBTKEY		key
+	PREINIT:
+	  dMY_CXT;
+	CODE:
+	{
+          DBT		value ;
+	
+	  DBT_clear(value) ; 
+	  CurrentDB = db ;
+	  RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ;
+	}
+	OUTPUT:
+	  RETVAL
+
+void
+db_FETCH(db, key, flags=0)
+	DB_File		db
+	DBTKEY		key
+	u_int		flags
+	PREINIT:
+	  dMY_CXT ;
+	  int RETVAL ;
+	CODE:
+	{
+            DBT		value ;
+
+	    DBT_clear(value) ; 
+	    CurrentDB = db ;
+	    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
+	PREINIT:
+	  dMY_CXT;
+	INIT:
+	  CurrentDB = db ;
+
+
+void
+db_FIRSTKEY(db)
+	DB_File		db
+	PREINIT:
+	  dMY_CXT ;
+	  int RETVAL ;
+	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) ;
+	}
+
+void
+db_NEXTKEY(db, key)
+	DB_File		db
+	DBTKEY		key = NO_INIT
+	PREINIT:
+	  dMY_CXT ;
+	  int RETVAL ;
+	CODE:
+	{
+	    DBT		value ;
+
+	    DBT_clear(key) ; 
+	    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
+	PREINIT:
+	  dMY_CXT;
+	CODE:
+	{
+	    DBTKEY	key ;
+	    DBT		value ;
+	    int		i ;
+	    int		One ;
+	    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)
+	    {
+		DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
+	        value.data = SvPVbyte(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->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ;
+#endif
+	        if (RETVAL != 0)
+	            break;
+	    }
+	}
+	OUTPUT:
+	    RETVAL
+
+void
+pop(db)
+	DB_File		db
+	PREINIT:
+	  dMY_CXT;
+	ALIAS:		POP = 1
+	PREINIT:
+	  I32 RETVAL;
+	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); 
+	    }
+	}
+
+void
+shift(db)
+	DB_File		db
+	PREINIT:
+	  dMY_CXT;
+	ALIAS:		SHIFT = 1
+	PREINIT:
+	  I32 RETVAL;
+	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
+	PREINIT:
+	  dMY_CXT;
+	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)
+	        {
+		    DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
+	            value.data = SvPVbyte(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
+	PREINIT:
+	  dMY_CXT;
+	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
+	PREINIT:
+	  dMY_CXT;
+	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
+	PREINIT:
+	  dMY_CXT;
+	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
+	PREINIT:
+	  dMY_CXT;
+	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
+	PREINIT:
+	  dMY_CXT ;
+	CODE:
+	  CurrentDB = db ;
+#ifdef DB_VERSION_MAJOR
+	  RETVAL = -1 ;
+	  {
+	    int	status = 0 ;
+	    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
+	PREINIT:
+	  dMY_CXT;
+	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
+	PREINIT:
+	  dMY_CXT;
+	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
+
+SV *
+filter_fetch_key(db, code)
+	DB_File		db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	CODE:
+	    DBM_setFilter(db->filter_fetch_key, code) ;
+
+SV *
+filter_store_key(db, code)
+	DB_File		db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	CODE:
+	    DBM_setFilter(db->filter_store_key, code) ;
+
+SV *
+filter_fetch_value(db, code)
+	DB_File		db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	CODE:
+	    DBM_setFilter(db->filter_fetch_value, code) ;
+
+SV *
+filter_store_value(db, code)
+	DB_File		db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	CODE:
+	    DBM_setFilter(db->filter_store_value, code) ;
+
diff --git a/cpan/DB_File/DB_File_BS b/cpan/DB_File/DB_File_BS
new file mode 100644
index 0000000000..9282c49881
--- /dev/null
+++ b/cpan/DB_File/DB_File_BS
@@ -0,0 +1,6 @@
+# NeXT needs /usr/lib/libposix.a to load along with DB_File.so
+if ( $dlsrc eq "dl_next.xs" ) {
+    @DynaLoader::dl_resolve_using = ( '/usr/lib/libposix.a' );
+}
+
+1;
diff --git a/cpan/DB_File/Makefile.PL b/cpan/DB_File/Makefile.PL
new file mode 100644
index 0000000000..a586a0445c
--- /dev/null
+++ b/cpan/DB_File/Makefile.PL
@@ -0,0 +1,358 @@
+#! perl -w
+
+use strict ;
+use ExtUtils::MakeMaker 5.16 ;
+use Config ;
+
+die "DB_File needs Perl 5.004_05 or better. This is $]\n" 
+    if $] <= 5.00404; 
+
+my $VER_INFO ;
+my $LIB_DIR ;
+my $INC_DIR ;
+my $DB_NAME ;
+my $LIBS ;
+my $COMPAT185 = "" ;
+
+ParseCONFIG() ;
+
+my @files = ('DB_File.pm', glob "t/*.t") ;
+UpDowngrade(@files);
+
+if (defined $DB_NAME)
+  { $LIBS = $DB_NAME }
+else {
+    if ($^O eq 'MSWin32')
+      { $LIBS = $Config{cc} =~ /gcc/ ? '-ldb' : '-llibdb' }
+    else
+      { $LIBS = '-ldb' }
+}
+
+# Solaris is special.
+#$LIBS .= " -lthread" if $^O eq 'solaris' ;
+
+# AIX is special.
+$LIBS .= " -lpthread" if $^O eq 'aix' ;
+
+# OS2 is a special case, so check for it now.
+my $OS2 = "" ;
+$OS2 = "-DOS2" if $Config{'osname'} eq 'os2' ;
+
+my $WALL = '' ;
+#$WALL = ' -Wall ';
+
+WriteMakefile(
+	NAME 		=> 'DB_File',
+	LIBS 		=> ["-L${LIB_DIR} $LIBS"],
+	INC		=> "-I$INC_DIR",
+    VERSION_FROM	=> 'DB_File.pm',
+	XS_VERSION      => eval MM->parse_version('DB_File.pm'),
+	XSPROTOARG	=> '-noprototypes',
+	DEFINE		=> "-D_NOT_CORE $OS2 $VER_INFO $COMPAT185 $WALL",
+	OBJECT		=> 'version$(OBJ_EXT) DB_File$(OBJ_EXT)',
+    ((ExtUtils::MakeMaker->VERSION() gt '6.30') 
+        ?  ('LICENSE'  => 'perl')         
+        : ()
+    ),
+    (
+    $] >= 5.005
+        ? (ABSTRACT_FROM => 'DB_File.pm',
+            AUTHOR       => 'Paul Marquess <pmqs@cpan.org>')
+        : ()
+    ),
+    
+
+	#OPTIMIZE	=> '-g',
+	'depend'	=> { 'Makefile'          => 'config.in',
+                             'version$(OBJ_EXT)' => 'version.c'},
+	'clean'		=> { FILES => 'constants.h constants.xs' },
+	'macro'		=> { INSTALLDIRS => 'perl', my_files => "@files" },
+        'dist'          => { COMPRESS => 'gzip', SUFFIX => 'gz',
+			     DIST_DEFAULT => 'MyDoubleCheck tardist'},    
+	);
+
+
+my @names = qw(
+	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
+	);
+
+if (eval {require ExtUtils::Constant; 1}) {
+    # Check the constants above all appear in @EXPORT in DB_File.pm
+    my %names = map { $_, 1} @names;
+    open F, "<DB_File.pm" or die "Cannot open DB_File.pm: $!\n";
+    while (<F>)
+    {
+        last if /^\s*\@EXPORT\s+=\s+qw\(/ ;
+    }
+
+    while (<F>)
+    {
+        last if /^\s*\)/ ;
+        /(\S+)/ ;
+        delete $names{$1} if defined $1 ;
+    }
+    close F ;
+
+    if ( keys %names )
+    {
+        my $missing = join ("\n\t", sort keys %names) ;
+        die "The following names are missing from \@EXPORT in DB_File.pm\n" .
+            "\t$missing\n" ;
+    }
+    
+
+    ExtUtils::Constant::WriteConstants(
+                                     NAME => 'DB_File',
+                                     NAMES => \@names,
+                                     C_FILE  => 'constants.h',
+                                     XS_FILE  => 'constants.xs',
+                                                                       
+                                    );
+} 
+else {
+    use File::Copy;
+    copy ('fallback.h', 'constants.h')
+      or die "Can't copy fallback.h to constants.h: $!";
+    copy ('fallback.xs', 'constants.xs')
+      or die "Can't copy fallback.xs to constants.xs: $!";
+}
+
+exit;
+
+
+sub MY::libscan
+{
+    my $self = shift ;
+    my $path = shift ;
+
+    return undef
+        if $path =~ /(~|\.bak)$/ || 
+           $path =~ /^\..*\.swp$/ ;
+
+    return $path;    
+}
+
+
+sub MY::postamble { <<'EOM' } ;
+
+MyDoubleCheck:
+	@echo Checking config.in is setup for a release
+	@(grep "^LIB.*/usr/local/BerkeleyDB" config.in && 	\
+	grep "^INCLUDE.*/usr/local/BerkeleyDB" config.in &&	\
+	grep "^#DBNAME.*" config.in) >/dev/null ||		\
+	    (echo config.in needs fixing ; exit 1)
+	@echo config.in is ok
+	@echo 
+	@echo Checking DB_File.xs is ok for a release.
+	@(perl -ne ' exit 1 if /^\s*#\s*define\s+TRACE/ ; ' DB_File.xs || \
+	    (echo DB_File.xs needs fixing ; exit 1))
+	@echo DB_File.xs is ok
+	@echo 
+	@echo Checking for $$^W in files: $(my_files)
+	@perl -ne '						\
+	    exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/;' $(my_files) ||	\
+	  (echo found unexpected $$^W ; exit 1)
+	@echo No $$^W found.
+	@echo 
+	@echo Checking for 'use vars' in files: $(my_files)
+	@perl -ne '						\
+	    exit 0 if /^__(DATA|END)__/;               	\
+	    exit 1 if /^\s*use\s+vars/;' $(my_files) ||	\
+	  (echo found unexpected "use vars"; exit 1)
+	@echo No 'use vars' found.
+	@echo 
+	@echo All files are OK for a release.
+	@echo 
+
+EOM
+
+
+
+sub ParseCONFIG
+{
+    my ($k, $v) ;
+    my @badkey = () ;
+    my %Info = () ;
+    my @Options = qw( INCLUDE LIB PREFIX HASH DBNAME COMPAT185 ) ;
+    my %ValidOption = map {$_, 1} @Options ;
+    my %Parsed = %ValidOption ;
+    my $CONFIG = 'config.in' ;
+
+    print "Parsing $CONFIG...\n" ;
+
+    # DBNAME & COMPAT185 are optional, so pretend they  have 
+    # been parsed.
+    delete $Parsed{'DBNAME'} ;
+    delete $Parsed{'COMPAT185'} ;
+    $Info{COMPAT185} = "No" ;
+
+
+    open(F, "$CONFIG") or die "Cannot open file $CONFIG: $!\n" ;
+    while (<F>) {
+	s/^\s*|\s*$//g ;
+	next if /^\s*$/ or /^\s*#/ ;
+	s/\s*#\s*$// ;
+
+	($k, $v) = split(/\s+=\s+/, $_, 2) ;
+	$k = uc $k ;
+	if ($ValidOption{$k}) {
+	    delete $Parsed{$k} ;
+	    $Info{$k} = $v ;
+	}
+	else {
+	    push(@badkey, $k) ;
+	}
+    }
+    close F ;
+
+    print "Unknown keys in $CONFIG ignored [@badkey]\n"
+	if @badkey ;
+
+    # check parsed values
+    my @missing = () ;
+    die "The following keys are missing from $CONFIG file: [@missing]\n" 
+        if @missing = keys %Parsed ;
+
+    $INC_DIR = $ENV{'DB_FILE_INCLUDE'} || $Info{'INCLUDE'} ;
+    $LIB_DIR = $ENV{'DB_FILE_LIB'} || $Info{'LIB'} ;
+    $DB_NAME = $ENV{'DB_FILE_NAME'} || $Info{'DBNAME'} ;
+    $COMPAT185 = "-DCOMPAT185 -DDB_LIBRARY_COMPATIBILITY_API" 
+        if (defined $ENV{'DB_FILE_COMPAT185'} && 
+		$ENV{'DB_FILE_COMPAT185'} =~ /^\s*(on|true|1)\s*$/i) ||
+		$Info{'COMPAT185'} =~ /^\s*(on|true|1)\s*$/i ; 
+    my $PREFIX  = $Info{'PREFIX'} ;
+    my $HASH    = $Info{'HASH'} ;
+
+    $VER_INFO = "-DmDB_Prefix_t=${PREFIX} -DmDB_Hash_t=${HASH}" ;
+
+    print <<EOM if 0 ;
+    INCLUDE	[$INC_DIR]
+    LIB		[$LIB_DIR]
+    HASH	[$HASH]
+    PREFIX	[$PREFIX]
+    DBNAME      [$DB_NAME]
+
+EOM
+
+    print "Looks Good.\n" ;
+
+}
+
+sub UpDowngrade
+{
+    my @files = @_ ;
+
+    # our      is stable from 5.6.0 onward
+    # warnings is stable from 5.6.1 onward
+
+    # Note: this code assumes that each statement it modifies is not
+    #       split across multiple lines.
+
+
+    my $warn_sub ;
+    my $our_sub ;
+
+    if ($] < 5.006001) {
+        # From: use|no warnings "blah"
+        # To:   local ($^W) = 1; # use|no warnings "blah"
+        #
+        # and
+        #
+        # From: warnings::warnif(x,y);
+        # To:   $^W && carp(y); # warnif -- x
+        $warn_sub = sub {
+	    s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ;
+	    s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ;
+
+	    s/^(\s*)warnings::warnif\s*\((.*?)\s*,\s*(.*?)\)\s*;/${1}\$^W && carp($3); # warnif - $2/ ;
+          };
+    }
+    else {
+        # From: local ($^W) = 1; # use|no warnings "blah"
+        # To:   use|no warnings "blah"
+        #
+        # and
+        #
+        # From: $^W && carp(y); # warnif -- x
+        # To:   warnings::warnif(x,y);
+        $warn_sub = sub {
+	    s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ;
+	    s/^(\s*)\$\^W\s+\&\&\s*carp\s*\((.*?)\)\s*;\s*#\s*warnif\s*-\s*(.*)/${1}warnings::warnif($3, $2);/ ;
+          };
+    }
+
+    if ($] < 5.006000) {
+        $our_sub = sub {
+	    if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) {
+                my $indent = $1;
+                my $vars = join ' ', split /\s*,\s*/, $2;
+                $_ = "${indent}use vars qw($vars);\n";
+            }
+          };
+    }
+    else {
+        $our_sub = sub {
+	    if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) {
+                my $indent = $1;
+                my $vars = join ', ', split ' ', $2;
+                $_ = "${indent}our ($vars);\n";
+            }
+          };
+    }
+
+    foreach (@files)
+      { doUpDown($our_sub, $warn_sub, $_) }
+}
+
+
+sub doUpDown
+{
+    my $our_sub = shift;
+    my $warn_sub = shift;
+
+    local ($^I) = ".bak" ;
+    local (@ARGV) = shift;
+
+    while (<>)
+    {
+	print, last if /^__(END|DATA)__/ ;
+
+	&{ $our_sub }();
+	&{ $warn_sub }();
+	print ;
+    }
+
+    return if eof ;
+
+    while (<>)
+      { print }
+}
+
+# end of file Makefile.PL
diff --git a/cpan/DB_File/config.in b/cpan/DB_File/config.in
new file mode 100755
index 0000000000..292b09a5fb
--- /dev/null
+++ b/cpan/DB_File/config.in
@@ -0,0 +1,97 @@
+# Filename:	config.in
+#
+# written by Paul Marquess <Paul.Marquess@btinternet.com>
+# last modified 9th Sept 1997
+# version 1.55
+
+# 1. Where is the file db.h?
+#
+#    Change the path below to point to the directory where db.h is
+#    installed on your system.
+
+INCLUDE	= /usr/local/BerkeleyDB/include
+#INCLUDE	= /usr/local/include
+#INCLUDE	= /usr/include
+
+# 2. Where is libdb?
+#
+#    Change the path below to point to the directory where libdb is
+#    installed on your system.
+
+LIB	= /usr/local/BerkeleyDB/lib
+#LIB	= /usr/local/lib
+#LIB	= /usr/lib
+
+# 3. What version of Berkely DB have you got?
+#
+#    If you have version 2.0 or greater, you can skip this question.
+#
+#    If you have Berkeley DB 1.78 or greater you shouldn't have to
+#    change the definitions for PREFIX and HASH below.
+#
+#    For older versions of Berkeley DB change both PREFIX and HASH to int.
+#    Version 1.71, 1.72 and 1.73 are known to need this change.
+#
+#    If you don't know what version you have have a look in the file db.h. 
+#
+#    Search for the string "DB_VERSION_MAJOR". If it is present, you
+#    have Berkeley DB version 2 (or greater).
+#
+#    If that didn't work, find the definition of the BTREEINFO typedef.
+#    Check the return type from the prefix element. It should look like
+#    this in an older copy of db.h:
+#
+#        int      (*prefix)      __P((const DBT *, const DBT *));  
+#
+#    and like this in a more recent copy:
+#
+#        size_t  (*prefix)       /* prefix function */
+#            __P((const DBT *, const DBT *));
+#
+#    Change the definition of PREFIX, below, to reflect the return type
+#    of the prefix function in your db.h.
+#
+#    Now find the definition of the HASHINFO typedef. Check the return
+#    type of the hash element. Older versions look like this:
+#
+#        int      (*hash) __P((const void *, size_t));      
+#
+#    newer like this:
+#
+#        u_int32_t               /* hash function */
+#                (*hash) __P((const void *, size_t));
+#
+#    Change the definition of HASH, below, to reflect the return type of
+#    the hash function in your db.h.
+#
+
+PREFIX	=	size_t
+HASH	=	u_int32_t
+
+# 4. Is the library called libdb?
+#
+#    If you have copies of both 1.x and 2.x Berkeley DB installed on
+#    your system it can sometimes be tricky to make sure you are using
+#    the correct one. Renaming one (or creating a symbolic link) to
+#    include the version number of the library can help.
+#
+#    For example, if you have both Berkeley DB 2.3.12 and 1.85 on your
+#    system and you want to use the Berkeley DB version 2 library you
+#    could rename the version 2 library from libdb.a to libdb-2.3.12.a and
+#    change the DBNAME line below to look like this:
+#
+#        DBNAME = -ldb-2.3.12
+#
+#    That will ensure you are linking the correct version of the DB
+#    library.
+#
+#    Note: If you are building this module with Win32, -llibdb will be
+#    used by default.
+#
+#    If you have changed the name of the library, uncomment the line
+#    below (by removing the leading #) and edit the line to use the name
+#    you have picked.
+ 
+#DBNAME = -ldb-2.4.10
+
+# end of file config.in
diff --git a/cpan/DB_File/dbinfo b/cpan/DB_File/dbinfo
new file mode 100644
index 0000000000..b8cd65a9a2
--- /dev/null
+++ b/cpan/DB_File/dbinfo
@@ -0,0 +1,133 @@
+#!/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.06 
+# Date		27th March 2008
+#
+#     Copyright (c) 1998-2008 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 =>	# DB_BTREEMAGIC
+            {
+			  Type 	   => "Btree",
+			  Versions => # DB_BTREEVERSION
+				{
+				  1	=> [0, "Unknown (older than 1.71)"],
+				  2	=> [0, "Unknown (older than 1.71)"],
+				  3	=> [0, "1.71 -> 1.85, 1.86"],
+				  4	=> [0, "Unknown"],
+				  5	=> [0, "2.0.0 -> 2.3.0"],
+				  6	=> [0, "2.3.1 -> 2.7.7"],
+				  7	=> [0, "3.0.x"],
+				  8	=> [0, "3.1.x -> 4.0.x"],
+				  9	=> [1, "4.1.x or greater"],
+				}
+			},
+	0x061561 => 	# DB_HASHMAGIC
+            {
+			  Type     => "Hash",
+			  Versions => # DB_HASHVERSION
+				{
+				  1	=> [0, "Unknown (older than 1.71)"],
+        			  2     => [0, "1.71 -> 1.85"],
+        			  3     => [0, "1.86"],
+        			  4     => [0, "2.0.0 -> 2.1.0"],
+        			  5     => [0, "2.2.6 -> 2.7.7"],
+        			  6     => [0, "3.0.x"],
+				  7	=> [0, "3.1.x -> 4.0.x"],
+				  8	=> [1, "4.1.x or greater"],
+				  9	=> [1, "4.6.x or greater"],
+				}
+			},
+	0x042253 => 	# DB_QAMMAGIC
+            {
+			  Type     => "Queue",
+			  Versions => # DB_QAMVERSION
+				{
+				  1	=> [0, "3.0.x"],
+				  2	=> [0, "3.1.x"],
+				  3	=> [0, "3.2.x -> 4.0.x"],
+				  4	=> [1, "4.1.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, 30 ;
+
+
+my (@info) = unpack("NNNNNNC", $buff) ;
+my (@info1) = unpack("VVVVVVC", $buff) ;
+my ($magic, $version, $endian, $encrypt) ;
+
+if ($Data{$info[0]}) # first try DB 1.x format, big endian
+{
+    $magic = $info[0] ;
+    $version = $info[1] ;
+    $endian  = "Big Endian" ;
+    $encrypt = "Not Supported";
+}
+elsif ($Data{$info1[0]}) # first try DB 1.x format, little endian
+{
+    $magic = $info1[0] ;
+    $version = $info1[1] ;
+    $endian  = "Little Endian" ;
+    $encrypt = "Not Supported";
+}
+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" ;
+
+if ( defined $type->{Versions}{$version} )
+{
+     $ver_string = $type->{Versions}{$version}[1];
+     if ($type->{Versions}{$version}[0] )
+       { $encrypt = $info[6] ? "Enabled" : "Disabled" }
+     else
+       { $encrypt = "Not Supported" }
+}
+
+print <<EOM ;
+File Type:		Berkeley DB $type->{Type} file.
+File Version ID:	$version
+Built with Berkeley DB:	$ver_string
+Byte Order:		$endian
+Magic:			$magic
+Encryption:             $encrypt
+EOM
+
+close F ;
+
+exit ;
diff --git a/cpan/DB_File/hints/dynixptx.pl b/cpan/DB_File/hints/dynixptx.pl
new file mode 100644
index 0000000000..bb5ffa56e6
--- /dev/null
+++ b/cpan/DB_File/hints/dynixptx.pl
@@ -0,0 +1,3 @@
+# Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug
+
+$self->{LIBS} = ['-lm -lc'];
diff --git a/cpan/DB_File/hints/sco.pl b/cpan/DB_File/hints/sco.pl
new file mode 100644
index 0000000000..ff60440949
--- /dev/null
+++ b/cpan/DB_File/hints/sco.pl
@@ -0,0 +1,2 @@
+# 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/cpan/DB_File/t/db-btree.t b/cpan/DB_File/t/db-btree.t
new file mode 100644
index 0000000000..0df890436b
--- /dev/null
+++ b/cpan/DB_File/t/db-btree.t
@@ -0,0 +1,1657 @@
+#!./perl -w
+ 
+use warnings;
+use strict;
+use Config;
+ 
+BEGIN {
+    if($ENV{PERL_CORE}) {
+        if ($Config{'extensions'} !~ /\bDB_File\b/ ) {
+            print "1..0 # Skip: DB_File was not built\n";
+            exit 0;
+        }
+    }
+}
+
+BEGIN
+{
+    if ($^O eq 'darwin'
+	&& (split(/\./, $Config{osvers}))[0] < 7 # Mac OS X 10.3 == Darwin 7
+	&& $Config{db_version_major} == 1
+	&& $Config{db_version_minor} == 0
+	&& $Config{db_version_patch} == 0) {
+	warn <<EOM;
+#
+# This test is known to crash in Mac OS X versions 10.2 (or earlier)
+# because of the buggy Berkeley DB version included with the OS.
+#
+EOM
+    }
+}
+
+use DB_File; 
+use Fcntl;
+
+print "1..197\n";
+
+unlink glob "__db.*";
+
+sub ok
+{
+    my $no = shift ;
+    my $result = shift ;
+ 
+    print "not " unless $result ;
+    print "ok $no\n" ;
+}
+
+sub lexical
+{
+    my(@a) = unpack ("C*", $a) ;
+    my(@b) = unpack ("C*", $b) ;
+
+    my $len = (@a > @b ? @b : @a) ;
+    my $i = 0 ;
+
+    foreach $i ( 0 .. $len -1) {
+        return $a[$i] - $b[$i] if $a[$i] != $b[$i] ;
+    }
+
+    return @a - @b ;
+}
+
+{
+    package Redirect ;
+    use Symbol ;
+
+    sub new
+    {
+        my $class = shift ;
+        my $filename = shift ;
+	my $fh = gensym ;
+	open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+	my $real_stdout = select($fh) ;
+	return bless [$fh, $real_stdout ] ;
+
+    }
+    sub DESTROY
+    {
+        my $self = shift ;
+	close $self->[0] ;
+	select($self->[1]) ;
+    }
+}
+
+sub docat
+{ 
+    my $file = shift;
+    local $/ = undef ;
+    open(CAT,$file) || die "Cannot open $file: $!";
+    my $result = <CAT>;
+    close(CAT);
+    $result = normalise($result) ;
+    return $result ;
+}   
+
+sub docat_del
+{ 
+    my $file = shift;
+    my $result = docat($file);
+    unlink $file ;
+    return $result ;
+}   
+
+sub normalise
+{
+    my $data = shift ;
+    $data =~ s#\r\n#\n#g 
+        if $^O eq 'cygwin' ;
+
+    return $data ;
+}
+
+sub safeUntie
+{
+    my $hashref = shift ;
+    my $no_inner = 1;
+    local $SIG{__WARN__} = sub {-- $no_inner } ;
+    untie %$hashref;
+    return $no_inner;
+}
+
+
+
+my $db185mode =  ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ;
+my $null_keys_allowed = ($DB_File::db_ver < 2.004010 
+				|| $DB_File::db_ver >= 3.1 );
+
+my $Dfile = "dbbtree.tmp";
+unlink $Dfile;
+
+umask(0);
+
+# Check the interface to BTREEINFO
+
+my $dbh = new DB_File::BTREEINFO ;
+ok(1, ! defined $dbh->{flags}) ;
+ok(2, ! defined $dbh->{cachesize}) ;
+ok(3, ! defined $dbh->{psize}) ;
+ok(4, ! defined $dbh->{lorder}) ;
+ok(5, ! defined $dbh->{minkeypage}) ;
+ok(6, ! defined $dbh->{maxkeypage}) ;
+ok(7, ! defined $dbh->{compare}) ;
+ok(8, ! defined $dbh->{prefix}) ;
+
+$dbh->{flags} = 3000 ;
+ok(9, $dbh->{flags} == 3000) ;
+
+$dbh->{cachesize} = 9000 ;
+ok(10, $dbh->{cachesize} == 9000);
+
+$dbh->{psize} = 400 ;
+ok(11, $dbh->{psize} == 400) ;
+
+$dbh->{lorder} = 65 ;
+ok(12, $dbh->{lorder} == 65) ;
+
+$dbh->{minkeypage} = 123 ;
+ok(13, $dbh->{minkeypage} == 123) ;
+
+$dbh->{maxkeypage} = 1234 ;
+ok(14, $dbh->{maxkeypage} == 1234 );
+
+# Check that an invalid entry is caught both for store & fetch
+eval '$dbh->{fred} = 1234' ;
+ok(15, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
+eval 'my $q = $dbh->{fred}' ;
+ok(16, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;
+
+# Now check the interface to BTREE
+
+my ($X, %h) ;
+ok(17, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;
+die "Could not tie: $!" unless $X;
+
+my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+   $blksize,$blocks) = stat($Dfile);
+
+my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
+
+ok(18, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640)
+   || $noMode{$^O} );
+
+my ($key, $value, $i);
+while (($key,$value) = each(%h)) {
+    $i++;
+}
+ok(19, !$i ) ;
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+ok(20, $h{'abc'} eq 'ABC' );
+ok(21, ! defined $h{'jimmy'} ) ;
+ok(22, ! exists $h{'jimmy'} ) ;
+ok(23,  defined $h{'abc'} ) ;
+
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+
+#$h{'b'} = 'B';
+$X->STORE('b', 'B') ;
+
+$h{'c'} = 'C';
+
+#$h{'d'} = 'D';
+$X->put('d', 'D') ;
+
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'X';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+
+# IMPORTANT - $X must be undefined before the untie otherwise the
+#             underlying DB close routine will not get called.
+undef $X ;
+untie(%h);
+
+# tie to the same file again
+ok(24, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ;
+
+# Modify an entry from the previous tie
+$h{'g'} = 'G';
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+$X->DELETE('goner3');
+
+my @keys = keys(%h);
+my @values = values(%h);
+
+ok(25, $#keys == 29 && $#values == 29) ;
+
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+    if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+	$key =~ y/a-z/A-Z/;
+	$i++ if $key eq $value;
+    }
+}
+
+ok(26, $i == 30) ;
+
+@keys = ('blurfl', keys(%h), 'dyick');
+ok(27, $#keys == 31) ;
+
+#Check that the keys can be retrieved in order
+my @b = keys %h ;
+my @c = sort lexical @b ;
+ok(28, ArrayCompare(\@b, \@c)) ;
+
+$h{'foo'} = '';
+ok(29, $h{'foo'} eq '' ) ;
+
+# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
+# This feature was reenabled in version 3.1 of Berkeley DB.
+my $result = 0 ;
+if ($null_keys_allowed) {
+    $h{''} = 'bar';
+    $result = ( $h{''} eq 'bar' );
+}
+else
+  { $result = 1 }
+ok(30, $result) ;
+
+# check cache overflow and numeric keys and contents
+my $ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ok(31, $ok);
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+   $blksize,$blocks) = stat($Dfile);
+ok(32, $size > 0 );
+
+@h{0..200} = 200..400;
+my @foo = @h{0..200};
+ok(33, join(':',200..400) eq join(':',@foo) );
+
+# Now check all the non-tie specific stuff
+
+
+# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
+# an existing record.
+ 
+my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
+ok(34, $status == 1 );
+ 
+# check that the value of the key 'x' has not been changed by the 
+# previous test
+ok(35, $h{'x'} eq 'X' );
+
+# standard put
+$status = $X->put('key', 'value') ;
+ok(36, $status == 0 );
+
+#check that previous put can be retrieved
+$value = 0 ;
+$status = $X->get('key', $value) ;
+ok(37, $status == 0 );
+ok(38, $value eq 'value' );
+
+# Attempting to delete an existing key should work
+
+$status = $X->del('q') ;
+ok(39, $status == 0 );
+if ($null_keys_allowed) {
+    $status = $X->del('') ;
+} else {
+    $status = 0 ;
+}
+ok(40, $status == 0 );
+
+# Make sure that the key deleted, cannot be retrieved
+ok(41, ! defined $h{'q'}) ;
+ok(42, ! defined $h{''}) ;
+
+undef $X ;
+untie %h ;
+
+ok(43, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE ));
+
+# Attempting to delete a non-existant key should fail
+
+$status = $X->del('joe') ;
+ok(44, $status == 1 );
+
+# Check the get interface
+
+# First a non-existing key
+$status = $X->get('aaaa', $value) ;
+ok(45, $status == 1 );
+
+# Next an existing key
+$status = $X->get('a', $value) ;
+ok(46, $status == 0 );
+ok(47, $value eq 'A' );
+
+# seq
+# ###
+
+# use seq to find an approximate match
+$key = 'ke' ;
+$value = '' ;
+$status = $X->seq($key, $value, R_CURSOR) ;
+ok(48, $status == 0 );
+ok(49, $key eq 'key' );
+ok(50, $value eq 'value' );
+
+# seq when the key does not match
+$key = 'zzz' ;
+$value = '' ;
+$status = $X->seq($key, $value, R_CURSOR) ;
+ok(51, $status == 1 );
+
+
+# use seq to set the cursor, then delete the record @ the cursor.
+
+$key = 'x' ;
+$value = '' ;
+$status = $X->seq($key, $value, R_CURSOR) ;
+ok(52, $status == 0 );
+ok(53, $key eq 'x' );
+ok(54, $value eq 'X' );
+$status = $X->del(0, R_CURSOR) ;
+ok(55, $status == 0 );
+$status = $X->get('x', $value) ;
+ok(56, $status == 1 );
+
+# ditto, but use put to replace the key/value pair.
+$key = 'y' ;
+$value = '' ;
+$status = $X->seq($key, $value, R_CURSOR) ;
+ok(57, $status == 0 );
+ok(58, $key eq 'y' );
+ok(59, $value eq 'Y' );
+
+$key = "replace key" ;
+$value = "replace value" ;
+$status = $X->put($key, $value, R_CURSOR) ;
+ok(60, $status == 0 );
+ok(61, $key eq 'replace key' );
+ok(62, $value eq 'replace value' );
+$status = $X->get('y', $value) ;
+ok(63, 1) ; # hard-wire to always pass. the previous test ($status == 1)
+	    # only worked because of a bug in 1.85/6
+
+# use seq to walk forwards through a file 
+
+$status = $X->seq($key, $value, R_FIRST) ;
+ok(64, $status == 0 );
+my $previous = $key ;
+
+$ok = 1 ;
+while (($status = $X->seq($key, $value, R_NEXT)) == 0)
+{
+    ($ok = 0), last if ($previous cmp $key) == 1 ;
+}
+
+ok(65, $status == 1 );
+ok(66, $ok == 1 );
+
+# use seq to walk backwards through a file 
+$status = $X->seq($key, $value, R_LAST) ;
+ok(67, $status == 0 );
+$previous = $key ;
+
+$ok = 1 ;
+while (($status = $X->seq($key, $value, R_PREV)) == 0)
+{
+    ($ok = 0), last if ($previous cmp $key) == -1 ;
+    #print "key = [$key] value = [$value]\n" ;
+}
+
+ok(68, $status == 1 );
+ok(69, $ok == 1 );
+
+
+# check seq FIRST/LAST
+
+# sync
+# ####
+
+$status = $X->sync ;
+ok(70, $status == 0 );
+
+
+# fd
+# ##
+
+$status = $X->fd ;
+ok(71, 1 );
+#ok(71, $status != 0 );
+
+
+undef $X ;
+untie %h ;
+
+unlink $Dfile;
+
+# Now try an in memory file
+my $Y;
+ok(72, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE ));
+
+# fd with an in memory file should return failure
+$status = $Y->fd ;
+ok(73, $status == -1 );
+
+
+undef $Y ;
+untie %h ;
+
+# Duplicate keys
+my $bt = new DB_File::BTREEINFO ;
+$bt->{flags} = R_DUP ;
+my ($YY, %hh);
+ok(74, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ;
+
+$hh{'Wall'} = 'Larry' ;
+$hh{'Wall'} = 'Stone' ; # Note the duplicate key
+$hh{'Wall'} = 'Brick' ; # Note the duplicate key
+$hh{'Wall'} = 'Brick' ; # Note the duplicate key and value
+$hh{'Smith'} = 'John' ;
+$hh{'mouse'} = 'mickey' ;
+
+# first work in scalar context
+ok(75, scalar $YY->get_dup('Unknown') == 0 );
+ok(76, scalar $YY->get_dup('Smith') == 1 );
+ok(77, scalar $YY->get_dup('Wall') == 4 );
+
+# now in list context
+my @unknown = $YY->get_dup('Unknown') ;
+ok(78, "@unknown" eq "" );
+
+my @smith = $YY->get_dup('Smith') ;
+ok(79, "@smith" eq "John" );
+
+{
+my @wall = $YY->get_dup('Wall') ;
+my %wall ;
+@wall{@wall} = @wall ;
+ok(80, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) );
+}
+
+# hash
+my %unknown = $YY->get_dup('Unknown', 1) ;
+ok(81, keys %unknown == 0 );
+
+my %smith = $YY->get_dup('Smith', 1) ;
+ok(82, keys %smith == 1 && $smith{'John'}) ;
+
+my %wall = $YY->get_dup('Wall', 1) ;
+ok(83, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 
+		&& $wall{'Brick'} == 2);
+
+undef $YY ;
+untie %hh ;
+unlink $Dfile;
+
+
+# test multiple callbacks
+my $Dfile1 = "btree1" ;
+my $Dfile2 = "btree2" ;
+my $Dfile3 = "btree3" ;
+ 
+my $dbh1 = new DB_File::BTREEINFO ;
+$dbh1->{compare} = sub { 
+	no warnings 'numeric' ;
+	$_[0] <=> $_[1] } ; 
+ 
+my $dbh2 = new DB_File::BTREEINFO ;
+$dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
+ 
+my $dbh3 = new DB_File::BTREEINFO ;
+$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
+ 
+ 
+my (%g, %k);
+tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) or die $!;
+tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) or die $!;
+tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) or die $!;
+ 
+my @Keys = qw( 0123 12 -1234 9 987654321 def  ) ;
+my (@srt_1, @srt_2, @srt_3);
+{ 
+  no warnings 'numeric' ;
+  @srt_1 = sort { $a <=> $b } @Keys ; 
+}
+@srt_2 = sort { $a cmp $b } @Keys ;
+@srt_3 = sort { length $a <=> length $b } @Keys ;
+ 
+foreach (@Keys) {
+    $h{$_} = 1 ;
+    $g{$_} = 1 ;
+    $k{$_} = 1 ;
+}
+ 
+sub ArrayCompare
+{
+    my($a, $b) = @_ ;
+ 
+    return 0 if @$a != @$b ;
+ 
+    foreach (1 .. length @$a)
+    {
+        return 0 unless $$a[$_] eq $$b[$_] ;
+    }
+ 
+    1 ;
+}
+ 
+ok(84, ArrayCompare (\@srt_1, [keys %h]) );
+ok(85, ArrayCompare (\@srt_2, [keys %g]) );
+ok(86, ArrayCompare (\@srt_3, [keys %k]) );
+
+untie %h ;
+untie %g ;
+untie %k ;
+unlink $Dfile1, $Dfile2, $Dfile3 ;
+
+# clear
+# #####
+
+ok(87, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+foreach (1 .. 10)
+  { $h{$_} = $_ * 100 }
+
+# check that there are 10 elements in the hash
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+    $i++;
+}
+ok(88, $i == 10);
+
+# now clear the hash
+%h = () ;
+
+# check it is empty
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+    $i++;
+}
+ok(89, $i == 0);
+
+untie %h ;
+unlink $Dfile1 ;
+
+{
+    # check that attempting to tie an array to a DB_BTREE will fail
+
+    my $filename = "xyz" ;
+    my @x ;
+    eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ;
+    ok(90, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ;
+    unlink $filename ;
+}
+
+{
+   # sub-class test
+
+   package Another ;
+
+   use warnings ;
+   use strict ;
+
+   open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+   print FILE <<'EOM' ;
+
+   package SubDB ;
+
+   use warnings ;
+   use strict ;
+   our (@ISA, @EXPORT);
+
+   require Exporter ;
+   use DB_File;
+   @ISA=qw(DB_File);
+   @EXPORT = @DB_File::EXPORT ;
+
+   sub STORE { 
+	my $self = shift ;
+        my $key = shift ;
+        my $value = shift ;
+        $self->SUPER::STORE($key, $value * 2) ;
+   }
+
+   sub FETCH { 
+	my $self = shift ;
+        my $key = shift ;
+        $self->SUPER::FETCH($key) - 1 ;
+   }
+
+   sub put { 
+	my $self = shift ;
+        my $key = shift ;
+        my $value = shift ;
+        $self->SUPER::put($key, $value * 3) ;
+   }
+
+   sub get { 
+	my $self = shift ;
+        $self->SUPER::get($_[0], $_[1]) ;
+	$_[1] -= 2 ;
+   }
+
+   sub A_new_method
+   {
+	my $self = shift ;
+        my $key = shift ;
+        my $value = $self->FETCH($key) ;
+	return "[[$value]]" ;
+   }
+
+   1 ;
+EOM
+
+    close FILE ;
+
+    BEGIN { push @INC, '.'; }    
+    eval 'use SubDB ; ';
+    main::ok(91, $@ eq "") ;
+    my %h ;
+    my $X ;
+    eval '
+	$X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE );
+	' ;
+
+    main::ok(92, $@ eq "") ;
+
+    my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+    main::ok(93, $@ eq "") ;
+    main::ok(94, $ret == 5) ;
+
+    my $value = 0;
+    $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
+    main::ok(95, $@ eq "") ;
+    main::ok(96, $ret == 10) ;
+
+    $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+    main::ok(97, $@ eq "" ) ;
+    main::ok(98, $ret == 1) ;
+
+    $ret = eval '$X->A_new_method("joe") ' ;
+    main::ok(99, $@ eq "") ;
+    main::ok(100, $ret eq "[[11]]") ;
+
+    undef $X;
+    untie(%h);
+    unlink "SubDB.pm", "dbbtree.tmp" ;
+
+}
+
+{
+   # DBM Filter tests
+   use warnings ;
+   use strict ;
+   my (%h, $db) ;
+   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   unlink $Dfile;
+
+   sub checkOutput
+   {
+       my($fk, $sk, $fv, $sv) = @_ ;
+       return
+           $fetch_key eq $fk && $store_key eq $sk && 
+	   $fetch_value eq $fv && $store_value eq $sv &&
+	   $_ eq 'original' ;
+   }
+   
+   ok(101, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
+   $db->filter_store_key   (sub { $store_key = $_ }) ;
+   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+   $db->filter_store_value (sub { $store_value = $_ }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   #                   fk   sk     fv   sv
+   ok(102, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(103, $h{"fred"} eq "joe");
+   #                   fk    sk     fv    sv
+   ok(104, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(105, $db->FIRSTKEY() eq "fred") ;
+   #                    fk     sk  fv  sv
+   ok(106, checkOutput( "fred", "", "", "")) ;
+
+   # replace the filters, but remember the previous set
+   my ($old_fk) = $db->filter_fetch_key   
+   			(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+   my ($old_sk) = $db->filter_store_key   
+   			(sub { $_ = lc $_ ; $store_key = $_ }) ;
+   my ($old_fv) = $db->filter_fetch_value 
+   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+   my ($old_sv) = $db->filter_store_value 
+   			(sub { s/o/x/g; $store_value = $_ }) ;
+   
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"Fred"} = "Joe" ;
+   #                   fk   sk     fv    sv
+   ok(107, checkOutput( "", "fred", "", "Jxe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(108, $h{"Fred"} eq "[Jxe]");
+   #                   fk   sk     fv    sv
+   ok(109, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(110, $db->FIRSTKEY() eq "FRED") ;
+   #                   fk   sk     fv    sv
+   ok(111, checkOutput( "FRED", "", "", "")) ;
+
+   # put the original filters back
+   $db->filter_fetch_key   ($old_fk);
+   $db->filter_store_key   ($old_sk);
+   $db->filter_fetch_value ($old_fv);
+   $db->filter_store_value ($old_sv);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(112, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(113, $h{"fred"} eq "joe");
+   ok(114, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(115, $db->FIRSTKEY() eq "fred") ;
+   ok(116, checkOutput( "fred", "", "", "")) ;
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(117, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(118, $h{"fred"} eq "joe");
+   ok(119, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(120, $db->FIRSTKEY() eq "fred") ;
+   ok(121, checkOutput( "", "", "", "")) ;
+
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
+{    
+    # DBM Filter with a closure
+
+    use warnings ;
+    use strict ;
+    my (%h, $db) ;
+
+    unlink $Dfile;
+    ok(122, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+    my %result = () ;
+
+    sub Closure
+    {
+        my ($name) = @_ ;
+	my $count = 0 ;
+	my @kept = () ;
+
+	return sub { ++$count ; 
+		     push @kept, $_ ; 
+		     $result{$name} = "$name - $count: [@kept]" ;
+		   }
+    }
+
+    $db->filter_store_key(Closure("store key")) ;
+    $db->filter_store_value(Closure("store value")) ;
+    $db->filter_fetch_key(Closure("fetch key")) ;
+    $db->filter_fetch_value(Closure("fetch value")) ;
+
+    $_ = "original" ;
+
+    $h{"fred"} = "joe" ;
+    ok(123, $result{"store key"} eq "store key - 1: [fred]");
+    ok(124, $result{"store value"} eq "store value - 1: [joe]");
+    ok(125, ! defined $result{"fetch key"} );
+    ok(126, ! defined $result{"fetch value"} );
+    ok(127, $_ eq "original") ;
+
+    ok(128, $db->FIRSTKEY() eq "fred") ;
+    ok(129, $result{"store key"} eq "store key - 1: [fred]");
+    ok(130, $result{"store value"} eq "store value - 1: [joe]");
+    ok(131, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(132, ! defined $result{"fetch value"} );
+    ok(133, $_ eq "original") ;
+
+    $h{"jim"}  = "john" ;
+    ok(134, $result{"store key"} eq "store key - 2: [fred jim]");
+    ok(135, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(136, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(137, ! defined $result{"fetch value"} );
+    ok(138, $_ eq "original") ;
+
+    ok(139, $h{"fred"} eq "joe");
+    ok(140, $result{"store key"} eq "store key - 3: [fred jim fred]");
+    ok(141, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(142, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(143, $result{"fetch value"} eq "fetch value - 1: [joe]");
+    ok(144, $_ eq "original") ;
+
+    undef $db ;
+    untie %h;
+    unlink $Dfile;
+}		
+
+{
+   # DBM Filter recursion detection
+   use warnings ;
+   use strict ;
+   my (%h, $db) ;
+   unlink $Dfile;
+
+   ok(145, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+   $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+   eval '$h{1} = 1234' ;
+   ok(146, $@ =~ /^recursion detected in filter_store_key at/ );
+   
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
+
+{
+   # Examples from the POD
+
+
+  my $file = "xyzt" ;
+  {
+    my $redirect = new Redirect $file ;
+
+    # BTREE example 1
+    ###
+
+    use warnings FATAL => qw(all) ;
+    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 ;
+
+    unlink "tree" ;
+  }  
+
+  delete $DB_BTREE->{'compare'} ;
+
+  ok(147, docat_del($file) eq <<'EOM') ;
+mouse
+Smith
+Wall
+EOM
+   
+  {
+    my $redirect = new Redirect $file ;
+
+    # BTREE example 2
+    ###
+
+    use warnings FATAL => qw(all) ;
+    use strict ;
+    use DB_File ;
+
+    my ($filename, %h);
+
+    $filename = "tree" ;
+    unlink $filename ;
+ 
+    # Enable duplicate records
+    $DB_BTREE->{'flags'} = R_DUP ;
+ 
+    tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
+	or die "Cannot open $filename: $!\n";
+ 
+    # Add some key/value pairs to the file
+    $h{'Wall'} = 'Larry' ;
+    $h{'Wall'} = 'Brick' ; # Note the duplicate key
+    $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
+    $h{'Smith'} = 'John' ;
+    $h{'mouse'} = 'mickey' ;
+
+    # iterate through the associative array
+    # and print each key/value pair.
+    foreach (keys %h)
+      { print "$_	-> $h{$_}\n" }
+
+    untie %h ;
+
+    unlink $filename ;
+  }  
+
+  ok(148, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ;
+Smith	-> John
+Wall	-> Brick
+Wall	-> Brick
+Wall	-> Brick
+mouse	-> mickey
+EOM
+Smith	-> John
+Wall	-> Larry
+Wall	-> Larry
+Wall	-> Larry
+mouse	-> mickey
+EOM
+
+  {
+    my $redirect = new Redirect $file ;
+
+    # BTREE example 3
+    ###
+
+    use warnings FATAL => qw(all) ;
+    use strict ;
+    use DB_File ;
+ 
+    my ($filename, $x, %h, $status, $key, $value);
+
+    $filename = "tree" ;
+    unlink $filename ;
+ 
+    # Enable duplicate records
+    $DB_BTREE->{'flags'} = R_DUP ;
+ 
+    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
+	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 ;
+  }
+
+  ok(149, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ;
+Smith	-> John
+Wall	-> Brick
+Wall	-> Brick
+Wall	-> Larry
+mouse	-> mickey
+EOM
+Smith	-> John
+Wall	-> Larry
+Wall	-> Brick
+Wall	-> Brick
+mouse	-> mickey
+EOM
+
+
+  {
+    my $redirect = new Redirect $file ;
+
+    # BTREE example 4
+    ###
+
+    use warnings FATAL => qw(all) ;
+    use strict ;
+    use DB_File ;
+ 
+    my ($filename, $x, %h);
+
+    $filename = "tree" ;
+ 
+    # Enable duplicate records
+    $DB_BTREE->{'flags'} = R_DUP ;
+ 
+    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
+	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" ; 
+ 
+    undef $x ;
+    untie %h ;
+  }
+
+  ok(150, docat_del($file) eq <<'EOM') ;
+Wall occurred 3 times
+Larry is there
+There are 2 Brick Walls
+Wall =>	[Brick Brick Larry]
+Smith =>	[John]
+Dog =>	[]
+EOM
+
+  {
+    my $redirect = new Redirect $file ;
+
+    # BTREE example 5
+    ###
+
+    use warnings FATAL => qw(all) ;
+    use strict ;
+    use DB_File ;
+ 
+    my ($filename, $x, %h, $found);
+
+    $filename = "tree" ;
+ 
+    # Enable duplicate records
+    $DB_BTREE->{'flags'} = R_DUP ;
+ 
+    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
+	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 ;
+  }
+
+  ok(151, docat_del($file) eq <<'EOM') ;
+Larry Wall is  there
+Harry Wall is not there
+EOM
+
+  {
+    my $redirect = new Redirect $file ;
+
+    # BTREE example 6
+    ###
+
+    use warnings FATAL => qw(all) ;
+    use strict ;
+    use DB_File ;
+ 
+    my ($filename, $x, %h, $found);
+
+    $filename = "tree" ;
+ 
+    # Enable duplicate records
+    $DB_BTREE->{'flags'} = R_DUP ;
+ 
+    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
+	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 ;
+
+    unlink $filename ;
+  }
+
+  ok(152, docat_del($file) eq <<'EOM') ;
+Larry Wall is not there
+EOM
+
+  {
+    my $redirect = new Redirect $file ;
+
+    # BTREE example 7
+    ###
+
+    use warnings FATAL => qw(all) ;
+    use strict ;
+    use DB_File ;
+    use Fcntl ;
+
+    my ($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 ;
+
+    unlink $filename ;
+
+  }
+
+  ok(153, docat_del($file) eq <<'EOM') ;
+IN ORDER
+Smith	-> John
+Wall	-> Larry
+Walls	-> Brick
+mouse	-> mickey
+
+PARTIAL MATCH
+Wa	-> Wall	-> Larry
+A	-> Smith	-> John
+a	-> mouse	-> mickey
+EOM
+
+}
+
+#{
+#   # R_SETCURSOR
+#   use strict ;
+#   my (%h, $db) ;
+#   unlink $Dfile;
+#
+#   ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+#
+#   $h{abc} = 33 ;
+#   my $k = "newest" ;
+#   my $v = 44 ;
+#   my $status = $db->put($k, $v, R_SETCURSOR) ;
+#   print "status = [$status]\n" ;
+#   ok(157, $status == 0) ;
+#   $status = $db->del($k, R_CURSOR) ;
+#   print "status = [$status]\n" ;
+#   ok(158, $status == 0) ;
+#   $k = "newest" ;
+#   ok(159, $db->get($k, $v, R_CURSOR)) ;
+#
+#   ok(160, keys %h == 1) ;
+#   
+#   undef $db ;
+#   untie %h;
+#   unlink $Dfile;
+#}
+
+{
+    # Bug ID 20001013.009
+    #
+    # test that $hash{KEY} = undef doesn't produce the warning
+    #     Use of uninitialized value in null operation 
+    use warnings ;
+    use strict ;
+    use DB_File ;
+
+    unlink $Dfile;
+    my %h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
+	or die "Can't open file: $!\n" ;
+    $h{ABC} = undef;
+    ok(154, $a eq "") ;
+    untie %h ;
+    unlink $Dfile;
+}
+
+{
+    # test that %hash = () doesn't produce the warning
+    #     Argument "" isn't numeric in entersub
+    use warnings ;
+    use strict ;
+    use DB_File ;
+
+    unlink $Dfile;
+    my %h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
+	or die "Can't open file: $!\n" ;
+    %h = (); ;
+    ok(155, $a eq "") ;
+    untie %h ;
+    unlink $Dfile;
+}
+
+{
+    # When iterating over a tied hash using "each", the key passed to FETCH
+    # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
+    # key in FETCH via a filter_fetch_key method we need to check that the
+    # modified key doesn't get passed to NEXTKEY.
+    # Also Test "keys" & "values" while we are at it.
+
+    use warnings ;
+    use strict ;
+    use DB_File ;
+
+    unlink $Dfile;
+    my $bad_key = 0 ;
+    my %h = () ;
+    my $db ;
+    ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+    $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
+    $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
+
+    $h{'Alpha_ABC'} = 2 ;
+    $h{'Alpha_DEF'} = 5 ;
+
+    ok(157, $h{'Alpha_ABC'} == 2);
+    ok(158, $h{'Alpha_DEF'} == 5);
+
+    my ($k, $v) = ("","");
+    while (($k, $v) = each %h) {}
+    ok(159, $bad_key == 0);
+
+    $bad_key = 0 ;
+    foreach $k (keys %h) {}
+    ok(160, $bad_key == 0);
+
+    $bad_key = 0 ;
+    foreach $v (values %h) {}
+    ok(161, $bad_key == 0);
+
+    undef $db ;
+    untie %h ;
+    unlink $Dfile;
+}
+
+{
+    # now an error to pass 'compare' a non-code reference
+    my $dbh = new DB_File::BTREEINFO ;
+
+    eval { $dbh->{compare} = 2 };
+    ok(162, $@ =~ /^Key 'compare' not associated with a code reference at/);
+
+    eval { $dbh->{prefix} = 2 };
+    ok(163, $@ =~ /^Key 'prefix' not associated with a code reference at/);
+
+}
+
+
+#{
+#    # recursion detection in btree
+#    my %hash ;
+#    unlink $Dfile;
+#    my $dbh = new DB_File::BTREEINFO ;
+#    $dbh->{compare} = sub { $hash{3} = 4 ; length $_[0] } ;
+# 
+# 
+#    my (%h);
+#    ok(164, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
+#
+#    eval {	$hash{1} = 2;
+#    		$hash{4} = 5;
+#	 };
+#
+#    ok(165, $@ =~ /^DB_File btree_compare: recursion detected/);
+#    {
+#        no warnings;
+#        untie %hash;
+#    }
+#    unlink $Dfile;
+#}
+ok(164,1);
+ok(165,1);
+
+{
+    # Check that two callbacks don't interact
+    my %hash1 ;
+    my %hash2 ;
+    my $h1_count = 0;
+    my $h2_count = 0;
+    unlink $Dfile, $Dfile2;
+    my $dbh1 = new DB_File::BTREEINFO ;
+    $dbh1->{compare} = sub { ++ $h1_count ; $_[0] cmp $_[1] } ; 
+
+    my $dbh2 = new DB_File::BTREEINFO ;
+    $dbh2->{compare} = sub { ;++ $h2_count ; $_[0] cmp $_[1] } ; 
+ 
+ 
+ 
+    my (%h);
+    ok(166, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) );
+    ok(167, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) );
+
+    $hash1{DEFG} = 5;
+    $hash1{XYZ} = 2;
+    $hash1{ABCDE} = 5;
+
+    $hash2{defg} = 5;
+    $hash2{xyz} = 2;
+    $hash2{abcde} = 5;
+
+    ok(168, $h1_count > 0);
+    ok(169, $h1_count == $h2_count);
+
+    ok(170, safeUntie \%hash1);
+    ok(171, safeUntie \%hash2);
+    unlink $Dfile, $Dfile2;
+}
+
+{
+   # Check that DBM Filter can cope with read-only $_
+
+   use warnings ;
+   use strict ;
+   my (%h, $db) ;
+   unlink $Dfile;
+
+   ok(172, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+   $db->filter_fetch_key   (sub { }) ;
+   $db->filter_store_key   (sub { }) ;
+   $db->filter_fetch_value (sub { }) ;
+   $db->filter_store_value (sub { }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   ok(173, $h{"fred"} eq "joe");
+
+   eval { my @r= grep { $h{$_} } (1, 2, 3) };
+   ok (174, ! $@);
+
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   $h{"fred"} = "joe" ;
+
+   ok(175, $h{"fred"} eq "joe");
+
+   ok(176, $db->FIRSTKEY() eq "fred") ;
+   
+   eval { my @r= grep { $h{$_} } (1, 2, 3) };
+   ok (177, ! $@);
+
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
+{
+   # Check low-level API works with filter
+
+   use warnings ;
+   use strict ;
+   my (%h, $db) ;
+   my $Dfile = "xxy.db";
+   unlink $Dfile;
+
+   ok(178, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+
+   $db->filter_fetch_key   (sub { $_ = unpack("i", $_) } );
+   $db->filter_store_key   (sub { $_ = pack("i", $_) } );
+   $db->filter_fetch_value (sub { $_ = unpack("i", $_) } );
+   $db->filter_store_value (sub { $_ = pack("i", $_) } );
+
+   $_ = 'fred';
+
+   my $key = 22 ;
+   my $value = 34 ;
+
+   $db->put($key, $value) ;
+   ok 179, $key == 22;
+   ok 180, $value == 34 ;
+   ok 181, $_ eq 'fred';
+   #print "k [$key][$value]\n" ;
+
+   my $val ;
+   $db->get($key, $val) ;
+   ok 182, $key == 22;
+   ok 183, $val == 34 ;
+   ok 184, $_ eq 'fred';
+
+   $key = 51 ;
+   $value = 454;
+   $h{$key} = $value ;
+   ok 185, $key == 51;
+   ok 186, $value == 454 ;
+   ok 187, $_ eq 'fred';
+
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
+
+
+{
+    # Regression Test for bug 30237
+    # Check that substr can be used in the key to db_put
+    # and that db_put does not trigger the warning
+    # 
+    #     Use of uninitialized value in subroutine entry
+
+
+    use warnings ;
+    use strict ;
+    my (%h, $db) ;
+    my $Dfile = "xxy.db";
+    unlink $Dfile;
+
+    ok(188, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ));
+
+    my $warned = '';
+    local $SIG{__WARN__} = sub {$warned = $_[0]} ;
+
+    # db-put with substr of key
+    my %remember = () ;
+    for my $ix ( 10 .. 12 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{$key} = $value ;
+        $db->put(substr($key,0), $value) ;
+    }
+
+    ok 189, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+
+    # db-put with substr of value
+    $warned = '';
+    for my $ix ( 20 .. 22 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{$key} = $value ;
+        $db->put($key, substr($value,0)) ;
+    }
+
+    ok 190, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+
+    # via the tied hash is not a problem, but check anyway
+    # substr of key
+    $warned = '';
+    for my $ix ( 30 .. 32 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{$key} = $value ;
+        $h{substr($key,0)} = $value ;
+    }
+
+    ok 191, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+
+    # via the tied hash is not a problem, but check anyway
+    # substr of value
+    $warned = '';
+    for my $ix ( 40 .. 42 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{$key} = $value ;
+        $h{$key} = substr($value,0) ;
+    }
+
+    ok 192, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+
+    my %bad = () ;
+    $key = '';
+    for ($status = $db->seq($key, $value, R_FIRST ) ;
+         $status == 0 ;
+         $status = $db->seq($key, $value, R_NEXT ) ) {
+
+        #print "# key [$key] value [$value]\n" ;
+        if (defined $remember{$key} && defined $value && 
+             $remember{$key} eq $value) {
+            delete $remember{$key} ;
+        }
+        else {
+            $bad{$key} = $value ;
+        }
+    }
+    
+    ok 193, keys %bad == 0 ;
+    ok 194, keys %remember == 0 ;
+
+    print "# missing -- $key $value\n" while ($key, $value) = each %remember;
+    print "# bad     -- $key $value\n" while ($key, $value) = each %bad;
+
+    # Make sure this fix does not break code to handle an undef key
+    # Berkeley DB undef key is bron between versions 2.3.16 and 
+    my $value = 'fred';
+    $warned = '';
+    $db->put(undef, $value) ;
+    ok 195, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+    $warned = '';
+
+    my $no_NULL = ($DB_File::db_ver >= 2.003016 && $DB_File::db_ver < 3.001) ;
+    print "# db_ver $DB_File::db_ver\n";
+    $value = '' ;
+    $db->get(undef, $value) ;
+    ok 196, $no_NULL || $value eq 'fred' or print "# got [$value]\n" ;
+    ok 197, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+    $warned = '';
+
+    undef $db ;
+    untie %h;
+    unlink $Dfile;
+}
+exit ;
diff --git a/cpan/DB_File/t/db-hash.t b/cpan/DB_File/t/db-hash.t
new file mode 100644
index 0000000000..4168362531
--- /dev/null
+++ b/cpan/DB_File/t/db-hash.t
@@ -0,0 +1,1225 @@
+#!./perl 
+ 
+use warnings;
+use strict;
+use Config;
+ 
+BEGIN {
+    if($ENV{PERL_CORE}) {
+        if ($Config{'extensions'} !~ /\bDB_File\b/ ) {
+            print "1..0 # Skip: DB_File was not built\n";
+            exit 0;
+        }
+    }
+}
+
+use DB_File; 
+use Fcntl;
+
+print "1..166\n";
+
+unlink glob "__db.*";
+
+sub ok
+{
+    my $no = shift ;
+    my $result = shift ;
+ 
+    print "not " unless $result ;
+    print "ok $no\n" ;
+
+    return $result ;
+}
+
+{
+    package Redirect ;
+    use Symbol ;
+
+    sub new
+    {
+        my $class = shift ;
+        my $filename = shift ;
+	my $fh = gensym ;
+	open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+	my $real_stdout = select($fh) ;
+	return bless [$fh, $real_stdout ] ;
+
+    }
+    sub DESTROY
+    {
+        my $self = shift ;
+	close $self->[0] ;
+	select($self->[1]) ;
+    }
+}
+
+sub docat_del
+{ 
+    my $file = shift;
+    local $/ = undef;
+    open(CAT,$file) || die "Cannot open $file: $!";
+    my $result = <CAT>;
+    close(CAT);
+    $result = normalise($result) ;
+    unlink $file ;
+    return $result;
+}   
+
+sub normalise
+{
+    my $data = shift ;
+    $data =~ s#\r\n#\n#g 
+        if $^O eq 'cygwin' ;
+    return $data ;
+}
+
+sub safeUntie
+{
+    my $hashref = shift ;
+    my $no_inner = 1;
+    local $SIG{__WARN__} = sub {-- $no_inner } ;
+    untie %$hashref;
+    return $no_inner;
+}
+
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $null_keys_allowed = ($DB_File::db_ver < 2.004010 
+				|| $DB_File::db_ver >= 3.1 );
+
+unlink $Dfile;
+
+umask(0);
+
+# Check the interface to HASHINFO
+
+my $dbh = new DB_File::HASHINFO ;
+
+ok(1, ! defined $dbh->{bsize}) ;
+ok(2, ! defined $dbh->{ffactor}) ;
+ok(3, ! defined $dbh->{nelem}) ;
+ok(4, ! defined $dbh->{cachesize}) ;
+ok(5, ! defined $dbh->{hash}) ;
+ok(6, ! defined $dbh->{lorder}) ;
+
+$dbh->{bsize} = 3000 ;
+ok(7, $dbh->{bsize} == 3000 );
+
+$dbh->{ffactor} = 9000 ;
+ok(8, $dbh->{ffactor} == 9000 );
+
+$dbh->{nelem} = 400 ;
+ok(9, $dbh->{nelem} == 400 );
+
+$dbh->{cachesize} = 65 ;
+ok(10, $dbh->{cachesize} == 65 );
+
+my $some_sub = sub {} ;
+$dbh->{hash} = $some_sub;
+ok(11, $dbh->{hash} eq $some_sub );
+
+$dbh->{lorder} = 1234 ;
+ok(12, $dbh->{lorder} == 1234 );
+
+# Check that an invalid entry is caught both for store & fetch
+eval '$dbh->{fred} = 1234' ;
+ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
+eval 'my $q = $dbh->{fred}' ;
+ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
+
+
+# Now check the interface to HASH
+my ($X, %h);
+ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+die "Could not tie: $!" unless $X;
+
+my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+   $blksize,$blocks) = stat($Dfile);
+
+my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
+
+ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) ||
+   $noMode{$^O} );
+
+my ($key, $value, $i);
+while (($key,$value) = each(%h)) {
+    $i++;
+}
+ok(17, !$i );
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+ok(18, $h{'abc'} eq 'ABC' );
+ok(19, !defined $h{'jimmy'} );
+ok(20, !exists $h{'jimmy'} );
+ok(21, exists $h{'abc'} );
+
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+
+#$h{'b'} = 'B';
+$X->STORE('b', 'B') ;
+
+$h{'c'} = 'C';
+
+#$h{'d'} = 'D';
+$X->put('d', 'D') ;
+
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'X';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+
+# IMPORTANT - $X must be undefined before the untie otherwise the
+#             underlying DB close routine will not get called.
+undef $X ;
+untie(%h);
+
+
+# tie to the same file again, do not supply a type - should default to HASH
+ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
+
+# Modify an entry from the previous tie
+$h{'g'} = 'G';
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+$X->DELETE('goner3');
+
+my @keys = keys(%h);
+my @values = values(%h);
+
+ok(23, $#keys == 29 && $#values == 29) ;
+
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+    if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+	$key =~ y/a-z/A-Z/;
+	$i++ if $key eq $value;
+    }
+}
+
+ok(24, $i == 30) ;
+
+@keys = ('blurfl', keys(%h), 'dyick');
+ok(25, $#keys == 31) ;
+
+$h{'foo'} = '';
+ok(26, $h{'foo'} eq '' );
+
+# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
+# This feature was reenabled in version 3.1 of Berkeley DB.
+my $result = 0 ;
+if ($null_keys_allowed) {
+    $h{''} = 'bar';
+    $result = ( $h{''} eq 'bar' );
+}
+else
+  { $result = 1 }
+ok(27, $result) ;
+
+# check cache overflow and numeric keys and contents
+my $ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ok(28, $ok );
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+   $blksize,$blocks) = stat($Dfile);
+ok(29, $size > 0 );
+
+@h{0..200} = 200..400;
+my @foo = @h{0..200};
+ok(30, join(':',200..400) eq join(':',@foo) );
+
+
+# Now check all the non-tie specific stuff
+
+# Check NOOVERWRITE will make put fail when attempting to overwrite
+# an existing record.
+ 
+my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
+ok(31, $status == 1 );
+ 
+# check that the value of the key 'x' has not been changed by the 
+# previous test
+ok(32, $h{'x'} eq 'X' );
+
+# standard put
+$status = $X->put('key', 'value') ;
+ok(33, $status == 0 );
+
+#check that previous put can be retrieved
+$value = 0 ;
+$status = $X->get('key', $value) ;
+ok(34, $status == 0 );
+ok(35, $value eq 'value' );
+
+# Attempting to delete an existing key should work
+
+$status = $X->del('q') ;
+ok(36, $status == 0 );
+
+# Make sure that the key deleted, cannot be retrieved
+{
+    no warnings 'uninitialized' ;
+    ok(37, $h{'q'} eq undef );
+}
+
+# Attempting to delete a non-existant key should fail
+
+$status = $X->del('joe') ;
+ok(38, $status == 1 );
+
+# Check the get interface
+
+# First a non-existing key
+$status = $X->get('aaaa', $value) ;
+ok(39, $status == 1 );
+
+# Next an existing key
+$status = $X->get('a', $value) ;
+ok(40, $status == 0 );
+ok(41, $value eq 'A' );
+
+# seq
+# ###
+
+# ditto, but use put to replace the key/value pair.
+
+# use seq to walk backwards through a file - check that this reversed is
+
+# check seq FIRST/LAST
+
+# sync
+# ####
+
+$status = $X->sync ;
+ok(42, $status == 0 );
+
+
+# fd
+# ##
+
+$status = $X->fd ;
+ok(43, 1 );
+#ok(43, $status != 0 );
+
+undef $X ;
+untie %h ;
+
+unlink $Dfile;
+
+# clear
+# #####
+
+ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+foreach (1 .. 10)
+  { $h{$_} = $_ * 100 }
+
+# check that there are 10 elements in the hash
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+    $i++;
+}
+ok(45, $i == 10);
+
+# now clear the hash
+%h = () ;
+
+# check it is empty
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+    $i++;
+}
+ok(46, $i == 0);
+
+untie %h ;
+unlink $Dfile ;
+
+
+# Now try an in memory file
+ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+# fd with an in memory file should return fail
+$status = $X->fd ;
+ok(48, $status == -1 );
+
+undef $X ;
+untie %h ;
+
+{
+    # check ability to override the default hashing
+    my %x ;
+    my $filename = "xyz" ;
+    my $hi = new DB_File::HASHINFO ;
+    $::count = 0 ;
+    $hi->{hash} = sub { ++$::count ; length $_[0] } ;
+    ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
+    $h{"abc"} = 123 ;
+    ok(50, $h{"abc"} == 123) ;
+    untie %x ;
+    unlink $filename ;
+    ok(51, $::count >0) ;
+}
+
+{
+    # check that attempting to tie an array to a DB_HASH will fail
+
+    my $filename = "xyz" ;
+    my @x ;
+    eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ;
+    ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ;
+    unlink $filename ;
+}
+
+{
+   # sub-class test
+
+   package Another ;
+
+   use warnings ;
+   use strict ;
+
+   open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+   print FILE <<'EOM' ;
+
+   package SubDB ;
+
+   use warnings ;
+   use strict ;
+   our (@ISA, @EXPORT);
+
+   require Exporter ;
+   use DB_File;
+   @ISA=qw(DB_File);
+   @EXPORT = @DB_File::EXPORT ;
+
+   sub STORE { 
+	my $self = shift ;
+        my $key = shift ;
+        my $value = shift ;
+        $self->SUPER::STORE($key, $value * 2) ;
+   }
+
+   sub FETCH { 
+	my $self = shift ;
+        my $key = shift ;
+        $self->SUPER::FETCH($key) - 1 ;
+   }
+
+   sub put { 
+	my $self = shift ;
+        my $key = shift ;
+        my $value = shift ;
+        $self->SUPER::put($key, $value * 3) ;
+   }
+
+   sub get { 
+	my $self = shift ;
+        $self->SUPER::get($_[0], $_[1]) ;
+	$_[1] -= 2 ;
+   }
+
+   sub A_new_method
+   {
+	my $self = shift ;
+        my $key = shift ;
+        my $value = $self->FETCH($key) ;
+	return "[[$value]]" ;
+   }
+
+   1 ;
+EOM
+
+    close FILE ;
+
+    BEGIN { push @INC, '.'; }             
+    eval 'use SubDB ; ';
+    main::ok(53, $@ eq "") ;
+    my %h ;
+    my $X ;
+    eval '
+	$X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
+	' ;
+
+    main::ok(54, $@ eq "") ;
+
+    my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+    main::ok(55, $@ eq "") ;
+    main::ok(56, $ret == 5) ;
+
+    my $value = 0;
+    $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
+    main::ok(57, $@ eq "") ;
+    main::ok(58, $ret == 10) ;
+
+    $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+    main::ok(59, $@ eq "" ) ;
+    main::ok(60, $ret == 1) ;
+
+    $ret = eval '$X->A_new_method("joe") ' ;
+    main::ok(61, $@ eq "") ;
+    main::ok(62, $ret eq "[[11]]") ;
+
+    undef $X;
+    untie(%h);
+    unlink "SubDB.pm", "dbhash.tmp" ;
+
+}
+
+{
+   # DBM Filter tests
+   use warnings ;
+   use strict ;
+   my (%h, $db) ;
+   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   unlink $Dfile;
+
+   sub checkOutput
+   {
+       no warnings 'uninitialized';
+       my($fk, $sk, $fv, $sv) = @_ ;
+
+       print "# Fetch Key   : expected '$fk' got '$fetch_key'\n" 
+           if $fetch_key ne $fk ;
+       print "# Fetch Value : expected '$fv' got '$fetch_value'\n" 
+           if $fetch_value ne $fv ;
+       print "# Store Key   : expected '$sk' got '$store_key'\n" 
+           if $store_key ne $sk ;
+       print "# Store Value : expected '$sv' got '$store_value'\n" 
+           if $store_value ne $sv ;
+       print "# \$_          : expected 'original' got '$_'\n" 
+           if $_ ne 'original' ;
+
+       return
+           $fetch_key   eq $fk && $store_key   eq $sk && 
+	   $fetch_value eq $fv && $store_value eq $sv &&
+	   $_ eq 'original' ;
+   }
+   
+   ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
+   $db->filter_store_key   (sub { $store_key = $_ }) ;
+   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+   $db->filter_store_value (sub { $store_value = $_ }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   #                   fk   sk     fv   sv
+   ok(64, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(65, $h{"fred"} eq "joe");
+   #                   fk    sk     fv    sv
+   ok(66, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   my ($k, $v) ;
+   $k = 'fred';
+   ok(67, ! $db->seq($k, $v, R_FIRST) ) ;
+   ok(68, $k eq "fred") ;
+   ok(69, $v eq "joe") ;
+   #                    fk     sk  fv  sv
+   ok(70, checkOutput( "fred", "fred", "joe", "")) ;
+
+   # replace the filters, but remember the previous set
+   my ($old_fk) = $db->filter_fetch_key   
+   			(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+   my ($old_sk) = $db->filter_store_key   
+   			(sub { $_ = lc $_ ; $store_key = $_ }) ;
+   my ($old_fv) = $db->filter_fetch_value 
+   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+   my ($old_sv) = $db->filter_store_value 
+   			(sub { s/o/x/g; $store_value = $_ }) ;
+   
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"Fred"} = "Joe" ;
+   #                   fk   sk     fv    sv
+   ok(71, checkOutput( "", "fred", "", "Jxe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(72, $h{"Fred"} eq "[Jxe]");
+   #                   fk   sk     fv    sv
+   ok(73, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $k = 'Fred'; $v ='';
+   ok(74, ! $db->seq($k, $v, R_FIRST) ) ;
+   ok(75, $k eq "FRED") or 
+    print "# k [$k]\n" ;
+   ok(76, $v eq "[Jxe]") ;
+   #                   fk   sk     fv    sv
+   ok(77, checkOutput( "FRED", "fred", "[Jxe]", "")) ;
+
+   # put the original filters back
+   $db->filter_fetch_key   ($old_fk);
+   $db->filter_store_key   ($old_sk);
+   $db->filter_fetch_value ($old_fv);
+   $db->filter_store_value ($old_sv);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(78, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(79, $h{"fred"} eq "joe");
+   ok(80, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   #ok(77, $db->FIRSTKEY() eq "fred") ;
+   $k = 'fred';
+   ok(81, ! $db->seq($k, $v, R_FIRST) ) ;
+   ok(82, $k eq "fred") ;
+   ok(83, $v eq "joe") ;
+   #                   fk   sk     fv    sv
+   ok(84, checkOutput( "fred", "fred", "joe", "")) ;
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(85, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(86, $h{"fred"} eq "joe");
+   ok(87, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $k = 'fred';
+   ok(88, ! $db->seq($k, $v, R_FIRST) ) ;
+   ok(89, $k eq "fred") ;
+   ok(90, $v eq "joe") ;
+   ok(91, checkOutput( "", "", "", "")) ;
+
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
+{    
+    # DBM Filter with a closure
+
+    use warnings ;
+    use strict ;
+    my (%h, $db) ;
+
+    unlink $Dfile;
+    ok(92, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+    my %result = () ;
+
+    sub Closure
+    {
+        my ($name) = @_ ;
+	my $count = 0 ;
+	my @kept = () ;
+
+	return sub { ++$count ; 
+		     push @kept, $_ ; 
+		     $result{$name} = "$name - $count: [@kept]" ;
+		   }
+    }
+
+    $db->filter_store_key(Closure("store key")) ;
+    $db->filter_store_value(Closure("store value")) ;
+    $db->filter_fetch_key(Closure("fetch key")) ;
+    $db->filter_fetch_value(Closure("fetch value")) ;
+
+    $_ = "original" ;
+
+    $h{"fred"} = "joe" ;
+    ok(93, $result{"store key"} eq "store key - 1: [fred]");
+    ok(94, $result{"store value"} eq "store value - 1: [joe]");
+    ok(95, ! defined $result{"fetch key"} );
+    ok(96, ! defined $result{"fetch value"} );
+    ok(97, $_ eq "original") ;
+
+    ok(98, $db->FIRSTKEY() eq "fred") ;
+    ok(99, $result{"store key"} eq "store key - 1: [fred]");
+    ok(100, $result{"store value"} eq "store value - 1: [joe]");
+    ok(101, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(102, ! defined $result{"fetch value"} );
+    ok(103, $_ eq "original") ;
+
+    $h{"jim"}  = "john" ;
+    ok(104, $result{"store key"} eq "store key - 2: [fred jim]");
+    ok(105, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(106, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(107, ! defined $result{"fetch value"} );
+    ok(108, $_ eq "original") ;
+
+    ok(109, $h{"fred"} eq "joe");
+    ok(110, $result{"store key"} eq "store key - 3: [fred jim fred]");
+    ok(111, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(112, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(113, $result{"fetch value"} eq "fetch value - 1: [joe]");
+    ok(114, $_ eq "original") ;
+
+    undef $db ;
+    untie %h;
+    unlink $Dfile;
+}		
+
+{
+   # DBM Filter recursion detection
+   use warnings ;
+   use strict ;
+   my (%h, $db) ;
+   unlink $Dfile;
+
+   ok(115, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+   $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+   eval '$h{1} = 1234' ;
+   ok(116, $@ =~ /^recursion detected in filter_store_key at/ );
+   
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
+
+{
+   # Examples from the POD
+
+  my $file = "xyzt" ;
+  {
+    my $redirect = new Redirect $file ;
+
+    use warnings FATAL => qw(all);
+    use strict ;
+    use DB_File ;
+    our (%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 ;
+
+    unlink "fruit" ;
+  }  
+
+  ok(117, docat_del($file) eq <<'EOM') ;
+Banana Exists
+
+orange -> orange
+tomato -> red
+banana -> yellow
+EOM
+   
+}
+
+{
+    # Bug ID 20001013.009
+    #
+    # test that $hash{KEY} = undef doesn't produce the warning
+    #     Use of uninitialized value in null operation 
+    use warnings ;
+    use strict ;
+    use DB_File ;
+
+    unlink $Dfile;
+    my %h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
+    $h{ABC} = undef;
+    ok(118, $a eq "") ;
+    untie %h ;
+    unlink $Dfile;
+}
+
+{
+    # test that %hash = () doesn't produce the warning
+    #     Argument "" isn't numeric in entersub
+    use warnings ;
+    use strict ;
+    use DB_File ;
+
+    unlink $Dfile;
+    my %h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
+    %h = (); ;
+    ok(119, $a eq "") ;
+    untie %h ;
+    unlink $Dfile;
+}
+
+{
+    # When iterating over a tied hash using "each", the key passed to FETCH
+    # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
+    # key in FETCH via a filter_fetch_key method we need to check that the
+    # modified key doesn't get passed to NEXTKEY.
+    # Also Test "keys" & "values" while we are at it.
+
+    use warnings ;
+    use strict ;
+    use DB_File ;
+
+    unlink $Dfile;
+    my $bad_key = 0 ;
+    my %h = () ;
+    my $db ;
+    ok(120, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+    $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
+    $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
+
+    $h{'Alpha_ABC'} = 2 ;
+    $h{'Alpha_DEF'} = 5 ;
+
+    ok(121, $h{'Alpha_ABC'} == 2);
+    ok(122, $h{'Alpha_DEF'} == 5);
+
+    my ($k, $v) = ("","");
+    while (($k, $v) = each %h) {}
+    ok(123, $bad_key == 0);
+
+    $bad_key = 0 ;
+    foreach $k (keys %h) {}
+    ok(124, $bad_key == 0);
+
+    $bad_key = 0 ;
+    foreach $v (values %h) {}
+    ok(125, $bad_key == 0);
+
+    undef $db ;
+    untie %h ;
+    unlink $Dfile;
+}
+
+{
+    # now an error to pass 'hash' a non-code reference
+    my $dbh = new DB_File::HASHINFO ;
+
+    eval { $dbh->{hash} = 2 };
+    ok(126, $@ =~ /^Key 'hash' not associated with a code reference at/);
+
+}
+
+
+#{
+#    # recursion detection in hash
+#    my %hash ;
+#    my $Dfile = "xxx.db";
+#    unlink $Dfile;
+#    my $dbh = new DB_File::HASHINFO ;
+#    $dbh->{hash} = sub { $hash{3} = 4 ; length $_[0] } ;
+# 
+# 
+#    ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
+#
+#    eval {	$hash{1} = 2;
+#    		$hash{4} = 5;
+#	 };
+#
+#    ok(128, $@ =~ /^DB_File hash callback: recursion detected/);
+#    {
+#        no warnings;
+#        untie %hash;
+#    }
+#    unlink $Dfile;
+#}
+
+#ok(127, 1);
+#ok(128, 1);
+
+{
+    # Check that two hash's don't interact
+    my %hash1 ;
+    my %hash2 ;
+    my $h1_count = 0;
+    my $h2_count = 0;
+    unlink $Dfile, $Dfile2;
+    my $dbh1 = new DB_File::HASHINFO ;
+    $dbh1->{hash} = sub { ++ $h1_count ; length $_[0] } ;
+
+    my $dbh2 = new DB_File::HASHINFO ;
+    $dbh2->{hash} = sub { ++ $h2_count ; length $_[0] } ;
+ 
+ 
+ 
+    my (%h);
+    ok(127, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) );
+    ok(128, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) );
+
+    $hash1{DEFG} = 5;
+    $hash1{XYZ} = 2;
+    $hash1{ABCDE} = 5;
+
+    $hash2{defg} = 5;
+    $hash2{xyz} = 2;
+    $hash2{abcde} = 5;
+
+    ok(129, $h1_count > 0);
+    ok(130, $h1_count == $h2_count);
+
+    ok(131, safeUntie \%hash1);
+    ok(132, safeUntie \%hash2);
+    unlink $Dfile, $Dfile2;
+}
+
+{
+    # Passing undef for flags and/or mode when calling tie could cause 
+    #     Use of uninitialized value in subroutine entry
+    
+
+    my $warn_count = 0 ;
+    #local $SIG{__WARN__} = sub { ++ $warn_count };
+    my %hash1;
+    unlink $Dfile;
+
+    tie %hash1, 'DB_File',$Dfile, undef;
+    ok(133, $warn_count == 0);
+    $warn_count = 0;
+    untie %hash1;
+    unlink $Dfile;
+    tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef;
+    ok(134, $warn_count == 0);
+    untie %hash1;
+    unlink $Dfile;
+    tie %hash1, 'DB_File',$Dfile, undef, undef;
+    ok(135, $warn_count == 0);
+    $warn_count = 0;
+
+    untie %hash1;
+    unlink $Dfile;
+}
+
+{
+   # Check that DBM Filter can cope with read-only $_
+
+   use warnings ;
+   use strict ;
+   my (%h, $db) ;
+   my $Dfile = "xxy.db";
+   unlink $Dfile;
+
+   ok(136, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+   $db->filter_fetch_key   (sub { }) ;
+   $db->filter_store_key   (sub { }) ;
+   $db->filter_fetch_value (sub { }) ;
+   $db->filter_store_value (sub { }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   ok(137, $h{"fred"} eq "joe");
+
+   eval { my @r= grep { $h{$_} } (1, 2, 3) };
+   ok (138, ! $@);
+
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   $h{"fred"} = "joe" ;
+
+   ok(139, $h{"fred"} eq "joe");
+
+   ok(140, $db->FIRSTKEY() eq "fred") ;
+   
+   eval { my @r= grep { $h{$_} } (1, 2, 3) };
+   ok (141, ! $@);
+
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
+{
+   # Check low-level API works with filter
+
+   use warnings ;
+   use strict ;
+   my (%h, $db) ;
+   my $Dfile = "xxy.db";
+   unlink $Dfile;
+
+   ok(142, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+
+   $db->filter_fetch_key   (sub { $_ = unpack("i", $_) } );
+   $db->filter_store_key   (sub { $_ = pack("i", $_) } );
+   $db->filter_fetch_value (sub { $_ = unpack("i", $_) } );
+   $db->filter_store_value (sub { $_ = pack("i", $_) } );
+
+   $_ = 'fred';
+
+   my $key = 22 ;
+   my $value = 34 ;
+
+   $db->put($key, $value) ;
+   ok 143, $key == 22;
+   ok 144, $value == 34 ;
+   ok 145, $_ eq 'fred';
+   #print "k [$key][$value]\n" ;
+
+   my $val ;
+   $db->get($key, $val) ;
+   ok 146, $key == 22;
+   ok 147, $val == 34 ;
+   ok 148, $_ eq 'fred';
+
+   $key = 51 ;
+   $value = 454;
+   $h{$key} = $value ;
+   ok 149, $key == 51;
+   ok 150, $value == 454 ;
+   ok 151, $_ eq 'fred';
+
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
+
+{
+    # Regression Test for bug 30237
+    # Check that substr can be used in the key to db_put
+    # and that db_put does not trigger the warning
+    # 
+    #     Use of uninitialized value in subroutine entry
+
+
+    use warnings ;
+    use strict ;
+    my (%h, $db) ;
+    my $Dfile = "xxy.db";
+    unlink $Dfile;
+
+    ok(152, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+    my $warned = '';
+    local $SIG{__WARN__} = sub {$warned = $_[0]} ;
+
+    # db-put with substr of key
+    my %remember = () ;
+    for my $ix ( 1 .. 2 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{$key} = $value ;
+        $db->put(substr($key,0), $value) ;
+    }
+
+    ok 153, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+
+    # db-put with substr of value
+    $warned = '';
+    for my $ix ( 10 .. 12 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{$key} = $value ;
+        $db->put($key, substr($value,0)) ;
+    }
+
+    ok 154, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+
+    # via the tied hash is not a problem, but check anyway
+    # substr of key
+    $warned = '';
+    for my $ix ( 30 .. 32 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{$key} = $value ;
+        $h{substr($key,0)} = $value ;
+    }
+
+    ok 155, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+
+    # via the tied hash is not a problem, but check anyway
+    # substr of value
+    $warned = '';
+    for my $ix ( 40 .. 42 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{$key} = $value ;
+        $h{$key} = substr($value,0) ;
+    }
+
+    ok 156, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+
+    my %bad = () ;
+    $key = '';
+    for ($status = $db->seq(substr($key,0), substr($value,0), R_FIRST ) ;
+         $status == 0 ;
+         $status = $db->seq(substr($key,0), substr($value,0), R_NEXT ) ) {
+
+        #print "# key [$key] value [$value]\n" ;
+        if (defined $remember{$key} && defined $value && 
+             $remember{$key} eq $value) {
+            delete $remember{$key} ;
+        }
+        else {
+            $bad{$key} = $value ;
+        }
+    }
+    
+    ok 157, keys %bad == 0 ;
+    ok 158, keys %remember == 0 ;
+
+    print "# missing -- $key=>$value\n" while ($key, $value) = each %remember;
+    print "# bad     -- $key=>$value\n" while ($key, $value) = each %bad;
+
+    # Make sure this fix does not break code to handle an undef key
+    # Berkeley DB undef key is broken between versions 2.3.16 and 3.1
+    my $value = 'fred';
+    $warned = '';
+    $db->put(undef, $value) ;
+    ok 159, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+    $warned = '';
+
+    my $no_NULL = ($DB_File::db_ver >= 2.003016 && $DB_File::db_ver < 3.001) ;
+    print "# db_ver $DB_File::db_ver\n";
+    $value = '' ;
+    $db->get(undef, $value) ;
+    ok 160, $no_NULL || $value eq 'fred' or print "# got [$value]\n" ;
+    ok 161, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+    $warned = '';
+
+    undef $db ;
+    untie %h;
+    unlink $Dfile;
+}
+
+{
+   # Check filter + substr
+
+   use warnings ;
+   use strict ;
+   my (%h, $db) ;
+   my $Dfile = "xxy.db";
+   unlink $Dfile;
+
+   ok(162, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+
+   {
+       $db->filter_fetch_key   (sub { lc $_ } );
+       $db->filter_store_key   (sub { uc $_ } );
+       $db->filter_fetch_value (sub { lc $_ } );
+       $db->filter_store_value (sub { uc $_ } );
+   }
+
+   $_ = 'fred';
+
+    # db-put with substr of key
+    my %remember = () ;
+    my $status = 0 ;
+    for my $ix ( 1 .. 2 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{$key} = $value ;
+        $status += $db->put(substr($key,0), substr($value,0)) ;
+    }
+
+    ok 163, $status == 0 or print "# Status $status\n" ;
+
+    if (1)
+    {
+       $db->filter_fetch_key   (undef);
+       $db->filter_store_key   (undef);
+       $db->filter_fetch_value (undef);
+       $db->filter_store_value (undef);
+    }
+
+    my %bad = () ;
+    my $key = '';
+    my $value = '';
+    for ($status = $db->seq($key, $value, R_FIRST ) ;
+         $status == 0 ;
+         $status = $db->seq($key, $value, R_NEXT ) ) {
+
+        #print "# key [$key] value [$value]\n" ;
+        if (defined $remember{$key} && defined $value && 
+             $remember{$key} eq $value) {
+            delete $remember{$key} ;
+        }
+        else {
+            $bad{$key} = $value ;
+        }
+    }
+    
+    ok 164, $_ eq 'fred';
+    ok 165, keys %bad == 0 ;
+    ok 166, keys %remember == 0 ;
+
+    print "# missing -- $key $value\n" while ($key, $value) = each %remember;
+    print "# bad     -- $key $value\n" while ($key, $value) = each %bad;
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
+exit ;
diff --git a/cpan/DB_File/t/db-recno.t b/cpan/DB_File/t/db-recno.t
new file mode 100644
index 0000000000..365abfd520
--- /dev/null
+++ b/cpan/DB_File/t/db-recno.t
@@ -0,0 +1,1596 @@
+#!./perl -w
+ 
+use warnings;
+use strict;
+use Config;
+ 
+BEGIN {
+    if($ENV{PERL_CORE}) {
+        if ($Config{'extensions'} !~ /\bDB_File\b/ ) {
+            print "1..0 # Skip: DB_File was not built\n";
+            exit 0;
+        }
+    }
+}
+
+use DB_File; 
+use Fcntl;
+our ($dbh, $Dfile, $bad_ones, $FA);
+
+# full tied array support started in Perl 5.004_57
+# Double check to see if it is available.
+
+{
+    sub try::TIEARRAY { bless [], "try" }
+    sub try::FETCHSIZE { $FA = 1 }
+    $FA = 0 ;
+    my @a ; 
+    tie @a, 'try' ;
+    my $a = @a ;
+}
+
+
+sub ok
+{
+    my $no = shift ;
+    my $result = shift ;
+
+    print "not " unless $result ;
+    print "ok $no\n" ;
+
+    return $result ;
+}
+
+{
+    package Redirect ;
+    use Symbol ;
+
+    sub new
+    {
+        my $class = shift ;
+        my $filename = shift ;
+	my $fh = gensym ;
+	open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+	my $real_stdout = select($fh) ;
+	return bless [$fh, $real_stdout ] ;
+
+    }
+    sub DESTROY
+    {
+        my $self = shift ;
+	close $self->[0] ;
+	select($self->[1]) ;
+    }
+}
+
+sub docat
+{
+    my $file = shift;
+    local $/ = undef;
+    open(CAT,$file) || die "Cannot open $file:$!";
+    my $result = <CAT>;
+    close(CAT);
+    normalise($result) ;
+    return $result;
+}
+
+sub docat_del
+{ 
+    my $file = shift;
+    my $result = docat($file);
+    unlink $file ;
+    return $result;
+}   
+
+sub safeUntie
+{
+    my $hashref = shift ;
+    my $no_inner = 1;
+    local $SIG{__WARN__} = sub {-- $no_inner } ;
+    untie @$hashref;
+    return $no_inner;
+}
+
+sub bad_one
+{
+    unless ($bad_ones++) {
+	print STDERR <<EOM ;
+#
+# Some older versions of Berkeley DB version 1 will fail db-recno
+# tests 61, 63, 64 and 65.
+EOM
+        if ($^O eq 'darwin'
+	    && $Config{db_version_major} == 1
+	    && $Config{db_version_minor} == 0
+	    && $Config{db_version_patch} == 0) {
+	    print STDERR <<EOM ;
+#
+# For example Mac OS X 10.2 (or earlier) has such an old
+# version of Berkeley DB.
+EOM
+	}
+
+	print STDERR <<EOM ;
+#
+# You can safely ignore the errors if you're never going to use the
+# broken functionality (recno databases with a modified bval). 
+# Otherwise you'll have to upgrade your DB library.
+#
+# If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the
+# last versions that were released. Berkeley DB version 2 is continually
+# being updated -- Check out http://www.sleepycat.com/ for more details.
+#
+EOM
+    }
+}
+
+sub normalise
+{
+    return unless $^O eq 'cygwin' ;
+    foreach (@_)
+      { s#\r\n#\n#g }     
+}
+
+BEGIN 
+{ 
+    { 
+        local $SIG{__DIE__} ; 
+        eval { require Data::Dumper ; import Data::Dumper } ; 
+    }
+ 
+    if ($@) {
+        *Dumper = sub { my $a = shift; return "[ @{ $a } ]" } ;
+    }          
+}
+
+my $splice_tests = 10 + 12 + 1; # ten regressions, plus the randoms
+my $total_tests = 181 ;
+$total_tests += $splice_tests if $FA ;
+print "1..$total_tests\n";   
+
+$Dfile = "recno.tmp";
+unlink $Dfile ;
+
+umask(0);
+
+# Check the interface to RECNOINFO
+
+$dbh = new DB_File::RECNOINFO ;
+ok(1, ! defined $dbh->{bval}) ;
+ok(2, ! defined $dbh->{cachesize}) ;
+ok(3, ! defined $dbh->{psize}) ;
+ok(4, ! defined $dbh->{flags}) ;
+ok(5, ! defined $dbh->{lorder}) ;
+ok(6, ! defined $dbh->{reclen}) ;
+ok(7, ! defined $dbh->{bfname}) ;
+
+$dbh->{bval} = 3000 ;
+ok(8, $dbh->{bval} == 3000 );
+
+$dbh->{cachesize} = 9000 ;
+ok(9, $dbh->{cachesize} == 9000 );
+
+$dbh->{psize} = 400 ;
+ok(10, $dbh->{psize} == 400 );
+
+$dbh->{flags} = 65 ;
+ok(11, $dbh->{flags} == 65 );
+
+$dbh->{lorder} = 123 ;
+ok(12, $dbh->{lorder} == 123 );
+
+$dbh->{reclen} = 1234 ;
+ok(13, $dbh->{reclen} == 1234 );
+
+$dbh->{bfname} = 1234 ;
+ok(14, $dbh->{bfname} == 1234 );
+
+
+# Check that an invalid entry is caught both for store & fetch
+eval '$dbh->{fred} = 1234' ;
+ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ );
+eval 'my $q = $dbh->{fred}' ;
+ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ );
+
+# Now check the interface to RECNOINFO
+
+my $X  ;
+my @h ;
+ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
+
+my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
+
+ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640)
+	||  $noMode{$^O} );
+
+#my $l = @h ;
+my $l = $X->length ;
+ok(19, ($FA ? @h == 0 : !$l) );
+
+my @data = qw( a b c d ever f g h  i j k longername m n o p) ;
+
+$h[0] = shift @data ;
+ok(20, $h[0] eq 'a' );
+
+my $ i;
+foreach (@data)
+  { $h[++$i] = $_ }
+
+unshift (@data, 'a') ;
+
+ok(21, defined $h[1] );
+ok(22, ! defined $h[16] );
+ok(23, $FA ? @h == @data : $X->length == @data );
+
+
+# Overwrite an entry & check fetch it
+$h[3] = 'replaced' ;
+$data[3] = 'replaced' ;
+ok(24, $h[3] eq 'replaced' );
+
+#PUSH
+my @push_data = qw(added to the end) ;
+($FA ? push(@h, @push_data) : $X->push(@push_data)) ;
+push (@data, @push_data) ;
+ok(25, $h[++$i] eq 'added' );
+ok(26, $h[++$i] eq 'to' );
+ok(27, $h[++$i] eq 'the' );
+ok(28, $h[++$i] eq 'end' );
+
+# POP
+my $popped = pop (@data) ;
+my $value = ($FA ? pop @h : $X->pop) ;
+ok(29, $value eq $popped) ;
+
+# SHIFT
+$value = ($FA ? shift @h : $X->shift) ;
+my $shifted = shift @data ;
+ok(30, $value eq $shifted );
+
+# UNSHIFT
+
+# empty list
+($FA ? unshift @h,() : $X->unshift) ;
+ok(31, ($FA ? @h == @data : $X->length == @data ));
+
+my @new_data = qw(add this to the start of the array) ;
+$FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ;
+unshift (@data, @new_data) ;
+ok(32, $FA ? @h == @data : $X->length == @data );
+ok(33, $h[0] eq "add") ;
+ok(34, $h[1] eq "this") ;
+ok(35, $h[2] eq "to") ;
+ok(36, $h[3] eq "the") ;
+ok(37, $h[4] eq "start") ;
+ok(38, $h[5] eq "of") ;
+ok(39, $h[6] eq "the") ;
+ok(40, $h[7] eq "array") ;
+ok(41, $h[8] eq $data[8]) ;
+
+# Brief test for SPLICE - more thorough 'soak test' is later.
+my @old;
+if ($FA) {
+    @old = splice(@h, 1, 2, qw(bananas just before));
+}
+else {
+    @old = $X->splice(1, 2, qw(bananas just before));
+}
+ok(42, $h[0] eq "add") ;
+ok(43, $h[1] eq "bananas") ;
+ok(44, $h[2] eq "just") ;
+ok(45, $h[3] eq "before") ;
+ok(46, $h[4] eq "the") ;
+ok(47, $h[5] eq "start") ;
+ok(48, $h[6] eq "of") ;
+ok(49, $h[7] eq "the") ;
+ok(50, $h[8] eq "array") ;
+ok(51, $h[9] eq $data[8]) ;
+$FA ? splice(@h, 1, 3, @old) : $X->splice(1, 3, @old);
+
+# Now both arrays should be identical
+
+my $ok = 1 ;
+my $j = 0 ;
+foreach (@data)
+{
+   $ok = 0, last if $_ ne $h[$j ++] ; 
+}
+ok(52, $ok );
+
+# Neagtive subscripts
+
+# get the last element of the array
+ok(53, $h[-1] eq $data[-1] );
+ok(54, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] );
+
+# get the first element using a negative subscript
+eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ;
+ok(55, $@ eq "" );
+ok(56, $h[0] eq "abcd" );
+
+# now try to read before the start of the array
+eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ;
+ok(57, $@ =~ '^Modification of non-creatable array value attempted' );
+
+# IMPORTANT - $X must be undefined before the untie otherwise the
+#             underlying DB close routine will not get called.
+undef $X ;
+ok(58, safeUntie \@h);
+
+unlink $Dfile;
+
+
+{
+    # Check bval defaults to \n
+
+    my @h = () ;
+    my $dbh = new DB_File::RECNOINFO ;
+    ok(59, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+    $h[0] = "abc" ;
+    $h[1] = "def" ;
+    $h[3] = "ghi" ;
+    ok(60, safeUntie \@h);
+    my $x = docat($Dfile) ;
+    unlink $Dfile;
+    ok(61, $x eq "abc\ndef\n\nghi\n") ;
+}
+
+{
+    # Change bval
+
+    my @h = () ;
+    my $dbh = new DB_File::RECNOINFO ;
+    $dbh->{bval} = "-" ;
+    ok(62, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+    $h[0] = "abc" ;
+    $h[1] = "def" ;
+    $h[3] = "ghi" ;
+    ok(63, safeUntie \@h);
+    my $x = docat($Dfile) ;
+    unlink $Dfile;
+    my $ok = ($x eq "abc-def--ghi-") ;
+    bad_one() unless $ok ;
+    ok(64, $ok) ;
+}
+
+{
+    # Check R_FIXEDLEN with default bval (space)
+
+    my @h = () ;
+    my $dbh = new DB_File::RECNOINFO ;
+    $dbh->{flags} = R_FIXEDLEN ;
+    $dbh->{reclen} = 5 ;
+    ok(65, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+    $h[0] = "abc" ;
+    $h[1] = "def" ;
+    $h[3] = "ghi" ;
+    ok(66, safeUntie \@h);
+    my $x = docat($Dfile) ;
+    unlink $Dfile;
+    my $ok = ($x eq "abc  def       ghi  ") ;
+    bad_one() unless $ok ;
+    ok(67, $ok) ;
+}
+
+{
+    # Check R_FIXEDLEN with user-defined bval
+
+    my @h = () ;
+    my $dbh = new DB_File::RECNOINFO ;
+    $dbh->{flags} = R_FIXEDLEN ;
+    $dbh->{bval} = "-" ;
+    $dbh->{reclen} = 5 ;
+    ok(68, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+    $h[0] = "abc" ;
+    $h[1] = "def" ;
+    $h[3] = "ghi" ;
+    ok(69, safeUntie \@h);
+    my $x = docat($Dfile) ;
+    unlink $Dfile;
+    my $ok = ($x eq "abc--def-------ghi--") ;
+    bad_one() unless $ok ;
+    ok(70, $ok) ;
+}
+
+{
+    # check that attempting to tie an associative array to a DB_RECNO will fail
+
+    my $filename = "xyz" ;
+    my %x ;
+    eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ;
+    ok(71, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ;
+    unlink $filename ;
+}
+
+{
+   # sub-class test
+
+   package Another ;
+
+   use warnings ;
+   use strict ;
+
+   open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+   print FILE <<'EOM' ;
+
+   package SubDB ;
+
+   use warnings ;
+   use strict ;
+   our (@ISA, @EXPORT);
+
+   require Exporter ;
+   use DB_File;
+   @ISA=qw(DB_File);
+   @EXPORT = @DB_File::EXPORT ;
+
+   sub STORE { 
+	my $self = shift ;
+        my $key = shift ;
+        my $value = shift ;
+        $self->SUPER::STORE($key, $value * 2) ;
+   }
+
+   sub FETCH { 
+	my $self = shift ;
+        my $key = shift ;
+        $self->SUPER::FETCH($key) - 1 ;
+   }
+
+   sub put { 
+	my $self = shift ;
+        my $key = shift ;
+        my $value = shift ;
+        $self->SUPER::put($key, $value * 3) ;
+   }
+
+   sub get { 
+	my $self = shift ;
+        $self->SUPER::get($_[0], $_[1]) ;
+	$_[1] -= 2 ;
+   }
+
+   sub A_new_method
+   {
+	my $self = shift ;
+        my $key = shift ;
+        my $value = $self->FETCH($key) ;
+	return "[[$value]]" ;
+   }
+
+   1 ;
+EOM
+
+    close FILE  or die "Could not close: $!";
+
+    BEGIN { push @INC, '.'; } 
+    eval 'use SubDB ; ';
+    main::ok(72, $@ eq "") ;
+    my @h ;
+    my $X ;
+    eval '
+	$X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO );
+	' ;
+    die "Could not tie: $!" unless $X;
+
+    main::ok(73, $@ eq "") ;
+
+    my $ret = eval '$h[3] = 3 ; return $h[3] ' ;
+    main::ok(74, $@ eq "") ;
+    main::ok(75, $ret == 5) ;
+
+    my $value = 0;
+    $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ;
+    main::ok(76, $@ eq "") ;
+    main::ok(77, $ret == 10) ;
+
+    $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+    main::ok(78, $@ eq "" ) ;
+    main::ok(79, $ret == 1) ;
+
+    $ret = eval '$X->A_new_method(1) ' ;
+    main::ok(80, $@ eq "") ;
+    main::ok(81, $ret eq "[[11]]") ;
+
+    undef $X;
+    main::ok(82, main::safeUntie \@h);
+    unlink "SubDB.pm", "recno.tmp" ;
+
+}
+
+{
+
+    # test $#
+    my $self ;
+    unlink $Dfile;
+    ok(83, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
+    $h[0] = "abc" ;
+    $h[1] = "def" ;
+    $h[2] = "ghi" ;
+    $h[3] = "jkl" ;
+    ok(84, $FA ? $#h == 3 : $self->length() == 4) ;
+    undef $self ;
+    ok(85, safeUntie \@h);
+    my $x = docat($Dfile) ;
+    ok(86, $x eq "abc\ndef\nghi\njkl\n") ;
+
+    # $# sets array to same length
+    $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ;
+    ok(87, $self) 
+        or warn "# $DB_File::Error\n";
+    if ($FA)
+      { $#h = 3 }
+    else 
+      { $self->STORESIZE(4) }
+    ok(88, $FA ? $#h == 3 : $self->length() == 4) ;
+    undef $self ;
+    ok(89, safeUntie \@h);
+    $x = docat($Dfile) ;
+    ok(90, $x eq "abc\ndef\nghi\njkl\n") ;
+
+    # $# sets array to bigger
+    ok(91, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+    if ($FA)
+      { $#h = 6 }
+    else 
+      { $self->STORESIZE(7) }
+    ok(92, $FA ? $#h == 6 : $self->length() == 7) ;
+    undef $self ;
+    ok(93, safeUntie \@h);
+    $x = docat($Dfile) ;
+    ok(94, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ;
+
+    # $# sets array smaller
+    ok(95, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+    if ($FA)
+      { $#h = 2 }
+    else 
+      { $self->STORESIZE(3) }
+    ok(96, $FA ? $#h == 2 : $self->length() == 3) ;
+    undef $self ;
+    ok(97, safeUntie \@h);
+    $x = docat($Dfile) ;
+    ok(98, $x eq "abc\ndef\nghi\n") ;
+
+    unlink $Dfile;
+
+
+}
+
+{
+   # DBM Filter tests
+   use warnings ;
+   use strict ;
+   my (@h, $db) ;
+   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   unlink $Dfile;
+
+   sub checkOutput
+   {
+       my($fk, $sk, $fv, $sv) = @_ ;
+
+       print "# Fetch Key   : expected '$fk' got '$fetch_key'\n" 
+           if $fetch_key ne $fk ;
+       print "# Fetch Value : expected '$fv' got '$fetch_value'\n" 
+           if $fetch_value ne $fv ;
+       print "# Store Key   : expected '$sk' got '$store_key'\n" 
+           if $store_key ne $sk ;
+       print "# Store Value : expected '$sv' got '$store_value'\n" 
+           if $store_value ne $sv ;
+       print "# \$_          : expected 'original' got '$_'\n" 
+           if $_ ne 'original' ;
+
+       return
+           $fetch_key   eq $fk && $store_key   eq $sk && 
+	   $fetch_value eq $fv && $store_value eq $sv &&
+	   $_ eq 'original' ;
+   }
+   
+   ok(99, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
+   $db->filter_store_key   (sub { $store_key = $_ }) ;
+   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+   $db->filter_store_value (sub { $store_value = $_ }) ;
+
+   $_ = "original" ;
+
+   $h[0] = "joe" ;
+   #                   fk   sk     fv   sv
+   ok(100, checkOutput( "", 0, "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(101, $h[0] eq "joe");
+   #                   fk  sk  fv    sv
+   ok(102, checkOutput( "", 0, "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(103, $db->FIRSTKEY() == 0) ;
+   #                    fk     sk  fv  sv
+   ok(104, checkOutput( 0, "", "", "")) ;
+
+   # replace the filters, but remember the previous set
+   my ($old_fk) = $db->filter_fetch_key   
+   			(sub { ++ $_ ; $fetch_key = $_ }) ;
+   my ($old_sk) = $db->filter_store_key   
+   			(sub { $_ *= 2 ; $store_key = $_ }) ;
+   my ($old_fv) = $db->filter_fetch_value 
+   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+   my ($old_sv) = $db->filter_store_value 
+   			(sub { s/o/x/g; $store_value = $_ }) ;
+   
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h[1] = "Joe" ;
+   #                   fk   sk     fv    sv
+   ok(105, checkOutput( "", 2, "", "Jxe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(106, $h[1] eq "[Jxe]");
+   #                   fk   sk     fv    sv
+   ok(107, checkOutput( "", 2, "[Jxe]", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(108, $db->FIRSTKEY() == 1) ;
+   #                   fk   sk     fv    sv
+   ok(109, checkOutput( 1, "", "", "")) ;
+   
+   # put the original filters back
+   $db->filter_fetch_key   ($old_fk);
+   $db->filter_store_key   ($old_sk);
+   $db->filter_fetch_value ($old_fv);
+   $db->filter_store_value ($old_sv);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h[0] = "joe" ;
+   ok(110, checkOutput( "", 0, "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(111, $h[0] eq "joe");
+   ok(112, checkOutput( "", 0, "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(113, $db->FIRSTKEY() == 0) ;
+   ok(114, checkOutput( 0, "", "", "")) ;
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h[0] = "joe" ;
+   ok(115, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(116, $h[0] eq "joe");
+   ok(117, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(118, $db->FIRSTKEY() == 0) ;
+   ok(119, checkOutput( "", "", "", "")) ;
+
+   undef $db ;
+   ok(120, safeUntie \@h);
+   unlink $Dfile;
+}
+
+{    
+    # DBM Filter with a closure
+
+    use warnings ;
+    use strict ;
+    my (@h, $db) ;
+
+    unlink $Dfile;
+    ok(121, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+    my %result = () ;
+
+    sub Closure
+    {
+        my ($name) = @_ ;
+	my $count = 0 ;
+	my @kept = () ;
+
+	return sub { ++$count ; 
+		     push @kept, $_ ; 
+		     $result{$name} = "$name - $count: [@kept]" ;
+		   }
+    }
+
+    $db->filter_store_key(Closure("store key")) ;
+    $db->filter_store_value(Closure("store value")) ;
+    $db->filter_fetch_key(Closure("fetch key")) ;
+    $db->filter_fetch_value(Closure("fetch value")) ;
+
+    $_ = "original" ;
+
+    $h[0] = "joe" ;
+    ok(122, $result{"store key"} eq "store key - 1: [0]");
+    ok(123, $result{"store value"} eq "store value - 1: [joe]");
+    ok(124, ! defined $result{"fetch key"} );
+    ok(125, ! defined $result{"fetch value"} );
+    ok(126, $_ eq "original") ;
+
+    ok(127, $db->FIRSTKEY() == 0 ) ;
+    ok(128, $result{"store key"} eq "store key - 1: [0]");
+    ok(129, $result{"store value"} eq "store value - 1: [joe]");
+    ok(130, $result{"fetch key"} eq "fetch key - 1: [0]");
+    ok(131, ! defined $result{"fetch value"} );
+    ok(132, $_ eq "original") ;
+
+    $h[7]  = "john" ;
+    ok(133, $result{"store key"} eq "store key - 2: [0 7]");
+    ok(134, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(135, $result{"fetch key"} eq "fetch key - 1: [0]");
+    ok(136, ! defined $result{"fetch value"} );
+    ok(137, $_ eq "original") ;
+
+    ok(138, $h[0] eq "joe");
+    ok(139, $result{"store key"} eq "store key - 3: [0 7 0]");
+    ok(140, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(141, $result{"fetch key"} eq "fetch key - 1: [0]");
+    ok(142, $result{"fetch value"} eq "fetch value - 1: [joe]");
+    ok(143, $_ eq "original") ;
+
+    undef $db ;
+    ok(144, safeUntie \@h);
+    unlink $Dfile;
+}		
+
+{
+   # DBM Filter recursion detection
+   use warnings ;
+   use strict ;
+   my (@h, $db) ;
+   unlink $Dfile;
+
+   ok(145, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+   $db->filter_store_key (sub { $_ = $h[0] }) ;
+
+   eval '$h[1] = 1234' ;
+   ok(146, $@ =~ /^recursion detected in filter_store_key at/ );
+   
+   undef $db ;
+   ok(147, safeUntie \@h);
+   unlink $Dfile;
+}
+
+
+{
+   # Examples from the POD
+
+  my $file = "xyzt" ;
+  {
+    my $redirect = new Redirect $file ;
+
+    use warnings FATAL => qw(all);
+    use strict ;
+    use DB_File ;
+
+    my $filename = "text" ;
+    unlink $filename ;
+
+    my @h ;
+    my $x = 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" ;
+
+    $FA ? push @h, "green", "black" 
+        : $x->push("green", "black") ;
+
+    my $elements = $FA ? scalar @h : $x->length ;
+    print "The array contains $elements entries\n" ;
+
+    my $last = $FA ? pop @h : $x->pop ;
+    print "popped $last\n" ;
+
+    $FA ? unshift @h, "white" 
+        : $x->unshift("white") ;
+    my $first = $FA ? shift @h : $x->shift ;
+    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" ;
+
+    undef $x ;
+    untie @h ;
+
+    unlink $filename ;
+  }  
+
+  ok(148, docat_del($file) eq <<'EOM') ;
+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
+EOM
+
+  my $save_output = "xyzt" ;
+  {
+    my $redirect = new Redirect $save_output ;
+
+    use warnings FATAL => qw(all);
+    use strict ;
+    our (@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 ;    
+
+    unlink $file ;
+  }  
+
+  ok(149, docat_del($save_output) eq <<'EOM') ;
+
+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
+EOM
+   
+}
+
+{
+    # Bug ID 20001013.009
+    #
+    # test that $hash{KEY} = undef doesn't produce the warning
+    #     Use of uninitialized value in null operation 
+    use warnings ;
+    use strict ;
+    use DB_File ;
+
+    unlink $Dfile;
+    my @h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 
+	or die "Can't open file: $!\n" ;
+    $h[0] = undef;
+    ok(150, $a eq "") ;
+    ok(151, safeUntie \@h);
+    unlink $Dfile;
+}
+
+{
+    # test that %hash = () doesn't produce the warning
+    #     Argument "" isn't numeric in entersub
+    use warnings ;
+    use strict ;
+    use DB_File ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+    unlink $Dfile;
+    my @h ;
+    
+    tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 
+	or die "Can't open file: $!\n" ;
+    @h = (); ;
+    ok(152, $a eq "") ;
+    ok(153, safeUntie \@h);
+    unlink $Dfile;
+}
+
+{
+   # Check that DBM Filter can cope with read-only $_
+
+   use warnings ;
+   use strict ;
+   my (@h, $db) ;
+   unlink $Dfile;
+
+   ok(154, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+   $db->filter_fetch_key   (sub { }) ;
+   $db->filter_store_key   (sub { }) ;
+   $db->filter_fetch_value (sub { }) ;
+   $db->filter_store_value (sub { }) ;
+
+   $_ = "original" ;
+
+   $h[0] = "joe" ;
+   ok(155, $h[0] eq "joe");
+
+   eval { my @r= grep { $h[$_] } (1, 2, 3) };
+   ok (156, ! $@);
+
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   $h[1] = "joe" ;
+
+   ok(157, $h[1] eq "joe");
+
+   eval { my @r= grep { $h[$_] } (1, 2, 3) };
+   ok (158, ! $@);
+
+   undef $db ;
+   untie @h;
+   unlink $Dfile;
+}
+
+{
+   # Check low-level API works with filter
+
+   use warnings ;
+   use strict ;
+   my (@h, $db) ;
+   my $Dfile = "xxy.db";
+   unlink $Dfile;
+
+   ok(159, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+
+   $db->filter_fetch_key   (sub { ++ $_ } );
+   $db->filter_store_key   (sub { -- $_ } );
+   $db->filter_fetch_value (sub { $_ = unpack("i", $_) } );
+   $db->filter_store_value (sub { $_ = pack("i", $_) } );
+
+   $_ = 'fred';
+
+   my $key = 22 ;
+   my $value = 34 ;
+
+   $db->put($key, $value) ;
+   ok 160, $key == 22;
+   ok 161, $value == 34 ;
+   ok 162, $_ eq 'fred';
+   #print "k [$key][$value]\n" ;
+
+   my $val ;
+   $db->get($key, $val) ;
+   ok 163, $key == 22;
+   ok 164, $val == 34 ;
+   ok 165, $_ eq 'fred';
+
+   $key = 51 ;
+   $value = 454;
+   $h[$key] = $value ;
+   ok 166, $key == 51;
+   ok 167, $value == 454 ;
+   ok 168, $_ eq 'fred';
+
+   undef $db ;
+   untie @h;
+   unlink $Dfile;
+}
+
+
+{
+    # Regression Test for bug 30237
+    # Check that substr can be used in the key to db_put
+    # and that db_put does not trigger the warning
+    # 
+    #     Use of uninitialized value in subroutine entry
+
+
+    use warnings ;
+    use strict ;
+    my (@h, $db) ;
+    my $status ;
+    my $Dfile = "xxy.db";
+    unlink $Dfile;
+
+    ok(169, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO) );
+
+    my $warned = '';
+    local $SIG{__WARN__} = sub {$warned = $_[0]} ;
+
+    # db-put with substr of key
+    my %remember = () ;
+    for my $ix ( 0 .. 2 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{substr($key,0, 1)} = $value ;
+        $db->put(substr($key,0, 1), $value) ;
+    }
+
+    ok 170, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+
+    # db-put with substr of value
+    $warned = '';
+    for my $ix ( 3 .. 5 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{$ix} = $value ;
+        $db->put($ix, substr($value,0)) ;
+    }
+
+    ok 171, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+
+    # via the tied array is not a problem, but check anyway
+    # substr of key
+    $warned = '';
+    for my $ix ( 6 .. 8 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{substr($key,0,1)} = $value ;
+        $h[substr($key,0,1)] = $value ;
+    }
+
+    ok 172, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+
+    # via the tied array is not a problem, but check anyway
+    # substr of value
+    $warned = '';
+    for my $ix ( 9 .. 10 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{$ix} = $value ;
+        $h[$ix] = substr($value,0) ;
+    }
+
+    ok 173, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+
+    my %bad = () ;
+    my $key = '';
+    for (my $status = $db->seq($key, $value, R_FIRST ) ;
+         $status == 0 ;
+         $status = $db->seq($key, $value, R_NEXT ) ) {
+
+        #print "# key [$key] value [$value]\n" ;
+        if (defined $remember{$key} && defined $value && 
+             $remember{$key} eq $value) {
+            delete $remember{$key} ;
+        }
+        else {
+            $bad{$key} = $value ;
+        }
+    }
+    
+    ok 174, keys %bad == 0 ;
+    ok 175, keys %remember == 0 ;
+
+    print "# missing -- $key $value\n" while ($key, $value) = each %remember;
+    print "# bad     -- $key $value\n" while ($key, $value) = each %bad;
+
+    # Make sure this fix does not break code to handle an undef key
+    my $value = 'fred';
+    $warned = '';
+    $status = $db->put(undef, $value) ;
+    ok 176, $status == 0
+      or print "# put failed - status $status\n";
+    ok 177, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+    $warned = '';
+
+    print "# db_ver $DB_File::db_ver\n";
+    $value = '' ;
+    $status = $db->get(undef, $value) ;
+    ok 178, $status == 0
+	or print "# get failed - status $status\n" ;
+    ok(179, $db->get(undef, $value) == 0) or print "# get failed\n" ;
+    ok 180, $value eq 'fred' or print "# got [$value]\n" ;
+    ok 181, $warned eq '' 
+      or print "# Caught warning [$warned]\n" ;
+    $warned = '';
+
+    undef $db ;
+    untie @h;
+    unlink $Dfile;
+}
+
+# Only test splice if this is a newish version of Perl
+exit unless $FA ;
+
+# Test SPLICE
+
+{
+    # check that the splice warnings are under the same lexical control
+    # as their non-tied counterparts.
+
+    use warnings;
+    use strict;
+
+    my $a = '';
+    my @a = (1);
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+    unlink $Dfile;
+    my @tied ;
+    
+    tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 
+	or die "Can't open file: $!\n" ;
+
+    # uninitialized offset
+    use warnings;
+    my $offset ;
+    $a = '';
+    splice(@a, $offset);
+    ok(182, $a =~ /^Use of uninitialized value /);
+    $a = '';
+    splice(@tied, $offset);
+    ok(183, $a =~ /^Use of uninitialized value in splice/);
+
+    no warnings 'uninitialized';
+    $a = '';
+    splice(@a, $offset);
+    ok(184, $a eq '');
+    $a = '';
+    splice(@tied, $offset);
+    ok(185, $a eq '');
+
+    # uninitialized length
+    use warnings;
+    my $length ;
+    $a = '';
+    splice(@a, 0, $length);
+    ok(186, $a =~ /^Use of uninitialized value /);
+    $a = '';
+    splice(@tied, 0, $length);
+    ok(187, $a =~ /^Use of uninitialized value in splice/);
+
+    no warnings 'uninitialized';
+    $a = '';
+    splice(@a, 0, $length);
+    ok(188, $a eq '');
+    $a = '';
+    splice(@tied, 0, $length);
+    ok(189, $a eq '');
+
+    # offset past end of array
+    use warnings;
+    $a = '';
+    splice(@a, 3);
+    my $splice_end_array = ($a =~ /^splice\(\) offset past end of array/);
+    $a = '';
+    splice(@tied, 3);
+    ok(190, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/);
+
+    no warnings 'misc';
+    $a = '';
+    splice(@a, 3);
+    ok(191, $a eq '');
+    $a = '';
+    splice(@tied, 3);
+    ok(192, $a eq '');
+
+    ok(193, safeUntie \@tied);
+    unlink $Dfile;
+}
+
+# 
+# These are a few regression tests: bundles of five arguments to pass
+# to test_splice().  The first four arguments correspond to those
+# given to splice(), and the last says which context to call it in
+# (scalar, list or void).
+# 
+# The expected result is not needed because we get that by running
+# Perl's built-in splice().
+# 
+my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion',
+		 'rarely', 'paleness' ],
+	       -4, -2,
+	       [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ],
+	       'void' ],
+
+	     [ [ 'a' ], -2, 1, [ 'B' ], 'void' ],
+
+	     [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ],
+	       0, -4,
+	       [ 'maids' ],
+	       'void' ],
+
+	     [ [ 'visibility', 'pocketful', 'rectangles' ],
+	       -10, 0,
+	       [ 'garbages' ],
+	       'void' ],
+
+	     [ [ 'sleeplessly' ],
+	       8, -4,
+	       [ 'Margery', 'clearing', 'repercussion', 'clubs',
+		 'arise' ],
+	       'void' ],
+
+	     [ [ 'chastises', 'recalculates' ],
+	       0, 0,
+	       [ 'momentariness', 'mediates', 'accents', 'toils',
+		 'regaled' ],
+	       'void' ],
+
+	     [ [ 'b', '' ],
+	       9, 8,
+	       [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
+	       'scalar' ],
+
+	     [ [ 'b', '' ],
+	       undef, undef,
+	       [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
+	       'scalar' ],
+	     
+	     [ [ 'riheb' ], -8, undef, [], 'void' ],
+
+	     [ [ 'uft', 'qnxs', '' ],
+	       6, -2,
+	       [ 'znp', 'mhnkh', 'bn' ],
+	       'void' ],
+	    );
+
+my $testnum = 194;
+my $failed = 0;
+my $tmp = "dbr$$";
+foreach my $test (@tests) {
+    my $err = test_splice(@$test);
+    if (defined $err) {
+	print STDERR "# failed: ", Dumper($test);
+	print STDERR "# error: $err\n";
+	$failed = 1;
+	ok($testnum++, 0);
+    }
+    else { ok($testnum++, 1) }
+}
+
+if ($failed) {
+    # Not worth running the random ones
+    print STDERR '# skipping ', $testnum++, "\n";
+}
+else {
+    # A thousand randomly-generated tests
+    $failed = 0;
+    srand(0);
+    foreach (0 .. 1000 - 1) {
+	my $test = rand_test();
+	my $err = test_splice(@$test);
+	if (defined $err) {
+	    print STDERR "# failed: ", Dumper($test);
+	    print STDERR "# error: $err\n";
+	    $failed = 1;
+	    print STDERR "# skipping any remaining random tests\n";
+	    last;
+	}
+    }
+
+    ok($testnum++, not $failed);
+}
+
+die "testnum ($testnum) != total_tests ($total_tests) + 1" 
+    if $testnum != $total_tests + 1;
+
+exit ;
+
+# Subroutines for SPLICE testing
+
+# test_splice()
+# 
+# Test the new splice() against Perl's built-in one.  The first four
+# parameters are those passed to splice(), except that the lists must
+# be (explicitly) passed by reference, and are not actually modified.
+# (It's just a test!)  The last argument specifies the context in
+# which to call the functions: 'list', 'scalar', or 'void'.
+# 
+# Returns:
+#   undef, if the two splices give the same results for the given
+#     arguments and context;
+# 
+#   an error message showing the difference, otherwise.
+# 
+# Reads global variable $tmp.
+# 
+sub test_splice {
+    die 'usage: test_splice(array, offset, length, list, context)' if @_ != 5;
+    my ($array, $offset, $length, $list, $context) = @_;
+    my @array = @$array;
+    my @list = @$list;
+
+    unlink $tmp;
+    
+    my @h;
+    my $H = tie @h, 'DB_File', $tmp, O_CREAT|O_RDWR, 0644, $DB_RECNO
+      or die "cannot open $tmp: $!";
+
+    my $i = 0;
+    foreach ( @array ) { $h[$i++] = $_ }
+    
+    return "basic DB_File sanity check failed"
+      if list_diff(\@array, \@h);
+
+    # Output from splice():
+    # Returned value (munged a bit), error msg, warnings
+    # 
+    my ($s_r, $s_error, @s_warnings);
+
+    my $gather_warning = sub { push @s_warnings, $_[0] };
+    if ($context eq 'list') {
+	my @r;
+	eval {
+	    local $SIG{__WARN__} = $gather_warning;
+	    @r = splice @array, $offset, $length, @list;
+	};
+	$s_error = $@;
+	$s_r = \@r;
+    }
+    elsif ($context eq 'scalar') {
+	my $r;
+	eval {
+	    local $SIG{__WARN__} = $gather_warning;
+	    $r = splice @array, $offset, $length, @list;
+	};
+	$s_error = $@;
+	$s_r = [ $r ];
+    }
+    elsif ($context eq 'void') {
+	eval {
+	    local $SIG{__WARN__} = $gather_warning;
+	    splice @array, $offset, $length, @list;
+	};
+	$s_error = $@;
+	$s_r = [];
+    }
+    else {
+	die "bad context $context";
+    }
+
+    foreach ($s_error, @s_warnings) {
+	chomp;
+	s/ at \S+ line \d+\.$//;
+	# only built-in splice identifies name of uninit value
+	s/(uninitialized value) \$\w+/$1/;
+    }
+
+    # Now do the same for DB_File's version of splice
+    my ($ms_r, $ms_error, @ms_warnings);
+    $gather_warning = sub { push @ms_warnings, $_[0] };
+    if ($context eq 'list') {
+	my @r;
+	eval {
+	    local $SIG{__WARN__} = $gather_warning;
+	    @r = splice @h, $offset, $length, @list;
+	};
+	$ms_error = $@;
+	$ms_r = \@r;
+    }
+    elsif ($context eq 'scalar') {
+	my $r;
+	eval {
+	    local $SIG{__WARN__} = $gather_warning;
+	    $r = splice @h, $offset, $length, @list;
+	};
+	$ms_error = $@;
+	$ms_r = [ $r ];
+    }
+    elsif ($context eq 'void') {
+	eval {
+	    local $SIG{__WARN__} = $gather_warning;
+	    splice @h, $offset, $length, @list;
+	};
+	$ms_error = $@;
+	$ms_r = [];
+    }
+    else {
+	die "bad context $context";
+    }
+
+    foreach ($ms_error, @ms_warnings) {
+	chomp;
+    s/ at \S+(\s+\S+)*? line \d+\.?.*//s;
+    }
+
+    return "different errors: '$s_error' vs '$ms_error'"
+      if $s_error ne $ms_error;
+    return('different return values: ' . Dumper($s_r) . ' vs ' . Dumper($ms_r))
+      if list_diff($s_r, $ms_r);
+    return('different changed list: ' . Dumper(\@array) . ' vs ' . Dumper(\@h))
+      if list_diff(\@array, \@h);
+
+    if ((scalar @s_warnings) != (scalar @ms_warnings)) {
+	return 'different number of warnings';
+    }
+
+    while (@s_warnings) {
+	my $sw  = shift @s_warnings;
+	my $msw = shift @ms_warnings;
+	
+	if (defined $sw and defined $msw) {
+	    $msw =~ s/ \(.+\)$//;
+	    $msw =~ s/ in splice$// if $] < 5.006;
+	    if ($sw ne $msw) {
+		return "different warning: '$sw' vs '$msw'";
+	    }
+	}
+	elsif (not defined $sw and not defined $msw) {
+	    # Okay.
+	}
+	else {
+	    return "one warning defined, another undef";
+	}
+    }
+    
+    undef $H;
+    untie @h;
+    
+    open(TEXT, $tmp) or die "cannot open $tmp: $!";
+    @h = <TEXT>; normalise @h; chomp @h;
+    close TEXT or die "cannot close $tmp: $!";
+    return('list is different when re-read from disk: '
+	   . Dumper(\@array) . ' vs ' . Dumper(\@h))
+      if list_diff(\@array, \@h);
+
+    unlink $tmp;
+
+    return undef; # success
+}
+
+
+# list_diff()
+#
+# Do two lists differ?
+#
+# Parameters:
+#   reference to first list
+#   reference to second list
+#
+# Returns true iff they differ.  Only works for lists of (string or
+# undef). 
+# 
+# Surely there is a better way to do this?
+# 
+sub list_diff {
+    die 'usage: list_diff(ref to first list, ref to second list)'
+      if @_ != 2;
+    my ($a, $b) = @_;
+    my @a = @$a; my @b = @$b;
+    return 1 if (scalar @a) != (scalar @b);
+    for (my $i = 0; $i < @a; $i++) {
+	my ($ae, $be) = ($a[$i], $b[$i]);
+	if (defined $ae and defined $be) {
+	    return 1 if $ae ne $be;
+	}
+	elsif (not defined $ae and not defined $be) {
+	    # Two undefined values are 'equal'
+	}
+	else {
+	    return 1;
+	}
+    }
+    return 0;
+} 
+
+
+# rand_test()
+# 
+# Think up a random ARRAY, OFFSET, LENGTH, LIST, and context.
+# ARRAY or LIST might be empty, and OFFSET or LENGTH might be
+# undefined.  Return a 'test' - a listref of these five things.
+# 
+sub rand_test {
+    die 'usage: rand_test()' if @_;
+    my @contexts = qw<list scalar void>;
+    my $context = $contexts[int(rand @contexts)];
+    return [ rand_list(),
+	     (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
+	     (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
+	     rand_list(),
+	     $context ];
+}
+
+
+sub rand_list {
+    die 'usage: rand_list()' if @_;
+    my @r;
+
+    while (rand() > 0.1 * (scalar @r + 1)) {
+	push @r, rand_word();
+    }
+    return \@r;
+}
+
+
+sub rand_word {
+    die 'usage: rand_word()' if @_;
+    my $r = '';
+    my @chars = qw<a b c d e f g h i j k l m n o p q r s t u v w x y z>;
+    while (rand() > 0.1 * (length($r) + 1)) {
+	$r .= $chars[int(rand(scalar @chars))];
+    }
+    return $r;
+}
+
+
diff --git a/cpan/DB_File/typemap b/cpan/DB_File/typemap
new file mode 100644
index 0000000000..c46b6851d7
--- /dev/null
+++ b/cpan/DB_File/typemap
@@ -0,0 +1,57 @@
+# typemap for Perl 5 interface to Berkeley 
+#
+# written by Paul Marquess <Paul.Marquess@btinternet.com>
+# last modified 20th June 2004
+# version 1.809
+#
+#################################### DB SECTION
+#
+# 
+
+u_int			T_U_INT
+DB_File			T_PTROBJ
+DBT			T_dbtdatum
+DBTKEY			T_dbtkeydatum
+
+INPUT
+T_dbtkeydatum
+    {
+	SV * my_sv = $arg;
+	DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\");
+	DBT_clear($var) ;
+	SvGETMAGIC(my_sv) ;
+        if (db->type == DB_RECNO) {
+	    if (SvOK(my_sv))
+	        Value = GetRecnoKey(aTHX_ db, SvIV(my_sv)) ; 
+            else
+	        Value = 1 ;
+	    $var.data = & Value; 
+	    $var.size = (int)sizeof(recno_t);
+        }
+        else if (SvOK(my_sv)) {
+	    STRLEN len;
+	    $var.data = SvPVbyte(my_sv, len);
+	    $var.size = (int)len;
+	}
+    }
+T_dbtdatum
+    {
+	SV * my_sv = $arg;
+	DBM_ckFilter(my_sv, filter_store_value, \"filter_store_value\");
+	DBT_clear($var) ;
+	SvGETMAGIC(my_sv) ;
+	if (SvOK(my_sv)) {
+	    STRLEN len;
+	    $var.data = SvPVbyte(my_sv, len);
+	    $var.size = (int)len;
+	}
+    }
+
+OUTPUT
+
+T_dbtkeydatum
+	OutputKey($arg, $var)
+T_dbtdatum
+	OutputValue($arg, $var)
+T_PTROBJ
+        sv_setref_pv($arg, dbtype, (void*)$var);
diff --git a/cpan/DB_File/version.c b/cpan/DB_File/version.c
new file mode 100644
index 0000000000..47158d3368
--- /dev/null
+++ b/cpan/DB_File/version.c
@@ -0,0 +1,83 @@
+/* 
+
+ version.c -- Perl 5 interface to Berkeley DB 
+
+ written by Paul Marquess <Paul.Marquess@btinternet.com>
+ last modified 2nd Jan 2002
+ version 1.802
+
+ All comments/suggestions/problems are welcome
+
+     Copyright (c) 1995-2002 Paul Marquess. All rights reserved.
+     This program is free software; you can redistribute it and/or
+     modify it under the same terms as Perl itself.
+
+ 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.
+
+
+*/
+
+#define PERL_NO_GET_CONTEXT
+#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 was build with libdb version %d.%d.%d,\nbut you are attempting to run it with 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 */
+
+}