DB_File-1.74

Message-ID: <000001c063c7$1b9d28a0$a20a140a@bfs.phone.com>

p4raw-id: //depot/perl@8094

diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes
index ad54382..31c22f7 100644 (file)
--- a/ext/DB_File/Changes
+++ b/ext/DB_File/Changes
@@ -292,7 +292,34 @@
      the updates to the documentation and writing DB_File::Lock (available
      on CPAN).
 
-1.73 27th April 2000
+1.73 31st May 2000
 
    * Added support in version.c for building with threaded Perl.
 
+   * Berkeley DB 3.1 has reenabled support for null keys. The test
+     harness has been updated to reflect this.
+
+1.74 10th December 2000
+
+   * A "close" call in DB_File.xs needed parenthesised to stop win32 from
+     thinking it was one of its macros.
+
+   * Updated dbinfo to support Berkeley DB 3.1 file format changes.
+
+   * DB_File.pm & the test hasness now use the warnings pragma (when
+     available).
+
+   * Included Perl core patch 7703 -- size argument for hash_cb is different
+     for Berkeley DB 3.x
+
+   * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C
+     treatment.
+
+   * @a = () produced the warning 'Argument "" isn't numeric in entersub'
+     This has been fixed. Thanks to Edward Avis for spotting this bug.
+
+   * Added note about building under Linux. Included patches.
+
+   * Included Perl core patch 8068 -- fix for bug 20001013.009 
+     When run with warnings enabled "$hash{XX} = undef " produced an
+     "Uninitialized value" warning. This has been fixed.

diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm
index a1ec0e6..2f3aafe 100644 (file)
--- a/ext/DB_File/DB_File.pm
+++ b/ext/DB_File/DB_File.pm
@@ -1,8 +1,8 @@
 # DB_File.pm -- Perl 5 interface to Berkeley DB 
 #
 # written by Paul Marquess (Paul.Marquess@btinternet.com)
-# last modified 26th April 2000
-# version 1.73
+# last modified 10th December 2000
+# version 1.74
 #
 #     Copyright (c) 1995-2000 Paul Marquess. All rights reserved.
 #     This program is free software; you can redistribute it and/or
@@ -13,6 +13,7 @@ package DB_File::HASHINFO ;
 
 require 5.003 ;
 
+use warnings;
 use strict;
 use Carp;
 require Tie::Hash;
@@ -104,6 +105,7 @@ sub CLEAR    { my $self = shift ; $self->NotHere("CLEAR") }
 
 package DB_File::RECNOINFO ;
 
+use warnings;
 use strict ;
 
 @DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;
@@ -121,6 +123,7 @@ sub TIEHASH
 
 package DB_File::BTREEINFO ;
 
+use warnings;
 use strict ;
 
 @DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ;
@@ -140,6 +143,7 @@ sub TIEHASH
 
 package DB_File ;
 
+use warnings;
 use strict;
 use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO 
             $db_version $use_XSLoader
@@ -147,7 +151,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO
 use Carp;
 
 
-$VERSION = "1.73" ;
+$VERSION = "1.74" ;
 
 #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
 $DB_BTREE = new DB_File::BTREEINFO ;
@@ -271,7 +275,7 @@ sub TIEARRAY
 sub CLEAR 
 {
     my $self = shift;
-    my $key = "" ;
+    my $key = 0 ;
     my $value = "" ;
     my $status = $self->seq($key, $value, R_FIRST());
     my @keys;
@@ -665,6 +669,7 @@ This example shows how to create a database, add key/value pairs to the
 database, delete keys/value pairs and finally how to enumerate the
 contents of the database.
 
+    use warnings ;
     use strict ;
     use DB_File ;
     use vars qw( %h $k $v ) ;
@@ -715,6 +720,7 @@ This script shows how to override the default sorting algorithm that
 BTREE uses. Instead of using the normal lexical ordering, a case
 insensitive compare function will be used.
 
+    use warnings ;
     use strict ;
     use DB_File ;
 
@@ -783,6 +789,7 @@ There are some difficulties in using the tied hash interface if you
 want to manipulate a BTREE database with duplicate keys. Consider this
 code:
 
+    use warnings ;
     use strict ;
     use DB_File ;
 
@@ -837,6 +844,7 @@ and the API in general.
 
 Here is the script above rewritten using the C<seq> API method.
 
+    use warnings ;
     use strict ;
     use DB_File ;
  
@@ -908,6 +916,7 @@ 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 ;
  
@@ -957,6 +966,7 @@ returns 0. Otherwise the method returns a non-zero value.
 
 Assuming the database from the previous example:
 
+    use warnings ;
     use strict ;
     use DB_File ;
  
@@ -995,6 +1005,7 @@ Otherwise the method returns a non-zero value.
 
 Again assuming the existence of the C<tree> database
 
+    use warnings ;
     use strict ;
     use DB_File ;
  
@@ -1039,6 +1050,7 @@ the use of the R_CURSOR flag with seq:
 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 ;
@@ -1143,6 +1155,7 @@ 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 ;
 
@@ -1232,6 +1245,7 @@ Here is a more complete example that makes use of some of the methods
 described above. It also makes use of the API interface directly (see 
 L<THE API INTERFACE>).
 
+    use warnings ;
     use strict ;
     use vars qw(@h $H $file $i) ;
     use DB_File ;
@@ -1583,6 +1597,7 @@ the database and have them removed when you read from the database. As I'm
 sure you have already guessed, this is a problem that DBM Filters can
 fix very easily.
 
+    use warnings ;
     use strict ;
     use DB_File ;
 
@@ -1625,6 +1640,7 @@ when reading.
 
 Here is a DBM Filter that does it:
 
+    use warnings ;
     use strict ;
     use DB_File ;
     my %hash ;
@@ -1791,6 +1807,7 @@ 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 ;
@@ -1947,6 +1964,7 @@ You will encounter this particular error message when you have the
 C<strict 'subs'> pragma (or the full strict pragma) in your script.
 Consider this script:
 
+    use warnings ;
     use strict ;
     use DB_File ;
     use vars qw(%x) ;

diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index e2eae43..751ceaa 100644 (file)
--- a/ext/DB_File/DB_File.xs
+++ b/ext/DB_File/DB_File.xs
@@ -3,8 +3,8 @@
  DB_File.xs -- Perl 5 interface to Berkeley DB 
 
  written by Paul Marquess <Paul.Marquess@btinternet.com>
- last modified 27th April 2000
- version 1.73
+ last modified 10 December 2000
+ version 1.74
 
  All comments/suggestions/problems are welcome
 
@@ -83,6 +83,9 @@
                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.
 
 */
 
@@ -128,7 +131,9 @@
 #    include <db.h>
 #endif
 
+#ifdef CAN_PROTOTYPE
 extern void __getBerkeleyDBInfo(void);
+#endif
 
 #ifndef pTHX
 #    define pTHX
@@ -586,6 +591,7 @@ const DBT * key2 ;
     return (retval) ;
 }
 
+
 #ifdef BERKELEY_DB_1_OR_2
 #    define HASH_CB_SIZE_TYPE size_t
 #else
@@ -1274,7 +1280,7 @@ SV *   sv ;
             Flags |= DB_TRUNCATE ;
 #endif
 
-        status = RETVAL->dbp->open(RETVAL->dbp, name, NULL, RETVAL->type, 
+        status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, 
                                Flags, mode) ; 
        /* printf("open returned %d %s\n", status, db_strerror(status)) ; */
 

diff --git a/ext/DB_File/dbinfo b/ext/DB_File/dbinfo
index 701ac61..240e3fc 100644 (file)
--- a/ext/DB_File/dbinfo
+++ b/ext/DB_File/dbinfo
@@ -4,10 +4,10 @@
 #                        a database file
 #
 # Author:      Paul Marquess  <Paul.Marquess@btinternet.com>
-# Version:     1.02 
-# Date         20th August 1999
+# Version:     1.03 
+# Date         17th September 2000
 #
-#     Copyright (c) 1998 Paul Marquess. All rights reserved.
+#     Copyright (c) 1998-2000 Paul Marquess. All rights reserved.
 #     This program is free software; you can redistribute it and/or
 #     modify it under the same terms as Perl itself.
 
@@ -28,7 +28,8 @@ my %Data =
                                  4     => "Unknown",
                                  5     => "2.0.0 -> 2.3.0",
                                  6     => "2.3.1 -> 2.7.7",
-                                 7     => "3.0.0 or greater",
+                                 7     => "3.0.x",
+                                 8     => "3.1.x or greater",
                                }
                        },
        0x061561 =>     {
@@ -40,7 +41,8 @@ my %Data =
                                  3     => "1.86",
                                  4     => "2.0.0 -> 2.1.0",
                                  5     => "2.2.6 -> 2.7.7",
-                                 6     => "3.0.0 or greater",
+                                 6     => "3.0.x",
+                                 7     => "3.1.x or greater",
                                }
                        },
        0x042253 =>     {

diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap
index b244e53..55439ee 100644 (file)
--- a/ext/DB_File/typemap
+++ b/ext/DB_File/typemap
@@ -1,8 +1,8 @@
 # typemap for Perl 5 interface to Berkeley 
 #
 # written by Paul Marquess <Paul.Marquess@btinternet.com>
-# last modified 7th September 1999
-# version 1.71
+# last modified 10th December 2000
+# version 1.74
 #
 #################################### DB SECTION
 #
@@ -34,7 +34,6 @@ T_dbtdatum
            $var.size = (int)PL_na;
        }
 
-
 OUTPUT
 
 T_dbtkeydatum

diff --git a/ext/DB_File/version.c b/ext/DB_File/version.c
index baa5bcd..6e55b2e 100644 (file)
--- a/ext/DB_File/version.c
+++ b/ext/DB_File/version.c
@@ -17,6 +17,8 @@
                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.
+
 
 */
 
@@ -27,7 +29,11 @@
 #include <db.h>
 
 void
+#ifdef CAN_PROTOTYPE
 __getBerkeleyDBInfo(void)
+#else
+__getBerkeleyDBInfo()
+#endif
 {
 #ifdef dTHX    
     dTHX;

diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t
index 11e86af..1822823 100755 (executable)
--- a/t/lib/db-btree.t
+++ b/t/lib/db-btree.t
@@ -9,10 +9,12 @@ BEGIN {
     }
 }
 
+use warnings;
+use strict;
 use DB_File; 
 use Fcntl;
 
-print "1..156\n";
+print "1..157\n";
 
 sub ok
 {
@@ -82,7 +84,9 @@ sub docat_del
 }   
 
 
-$db185mode =  ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ;
+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;
@@ -128,17 +132,19 @@ ok(16, $dbh->{prefix} == 1234 );
 # Check that an invalid entry is caught both for store & fetch
 eval '$dbh->{fred} = 1234' ;
 ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
-eval '$q = $dbh->{fred}' ;
+eval 'my $q = $dbh->{fred}' ;
 ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;
 
 # Now check the interface to BTREE
 
+my ($X, %h) ;
 ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;
 
-($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
    $blksize,$blocks) = stat($Dfile);
 ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
 
+my ($key, $value, $i);
 while (($key,$value) = each(%h)) {
     $i++;
 }
@@ -209,8 +215,8 @@ $h{'goner3'} = 'snork';
 delete $h{'goner1'};
 $X->DELETE('goner3');
 
-@keys = keys(%h);
-@values = values(%h);
+my @keys = keys(%h);
+my @values = values(%h);
 
 ok(27, $#keys == 29 && $#values == 29) ;
 
@@ -235,12 +241,19 @@ ok(30, ArrayCompare(\@b, \@c)) ;
 $h{'foo'} = '';
 ok(31, $h{'foo'} eq '' ) ;
 
-#$h{''} = 'bar';
-#ok(32, $h{''} eq 'bar' );
-ok(32,1) ;
+# 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(32, $result) ;
 
 # check cache overflow and numeric keys and contents
-$ok = 1;
+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(33, $ok);
@@ -250,7 +263,7 @@ ok(33, $ok);
 ok(34, $size > 0 );
 
 @h{0..200} = 200..400;
-@foo = @h{0..200};
+my @foo = @h{0..200};
 ok(35, join(':',200..400) eq join(':',@foo) );
 
 # Now check all the non-tie specific stuff
@@ -259,7 +272,7 @@ ok(35, join(':',200..400) eq join(':',@foo) );
 # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
 # an existing record.
  
-$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
+my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
 ok(36, $status == 1 );
  
 # check that the value of the key 'x' has not been changed by the 
@@ -280,9 +293,12 @@ ok(40, $value eq 'value' );
 
 $status = $X->del('q') ;
 ok(41, $status == 0 );
-#$status = $X->del('') ;
-#ok(42, $status == 0 );
-ok(42,1) ;
+if ($null_keys_allowed) {
+    $status = $X->del('') ;
+} else {
+    $status = 0 ;
+}
+ok(42, $status == 0 );
 
 # Make sure that the key deleted, cannot be retrieved
 ok(43, ! defined $h{'q'}) ;
@@ -362,7 +378,7 @@ ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1)
 
 $status = $X->seq($key, $value, R_FIRST) ;
 ok(66, $status == 0 );
-$previous = $key ;
+my $previous = $key ;
 
 $ok = 1 ;
 while (($status = $X->seq($key, $value, R_NEXT)) == 0)
@@ -411,6 +427,7 @@ untie %h ;
 unlink $Dfile;
 
 # Now try an in memory file
+my $Y;
 ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE ));
 
 # fd with an in memory file should return failure
@@ -424,6 +441,7 @@ untie %h ;
 # Duplicate keys
 my $bt = new DB_File::BTREEINFO ;
 $bt->{flags} = R_DUP ;
+my ($YY, %hh);
 ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ;
 
 $hh{'Wall'} = 'Larry' ;
@@ -469,34 +487,38 @@ unlink $Dfile;
 
 
 # test multiple callbacks
-$Dfile1 = "btree1" ;
-$Dfile2 = "btree2" ;
-$Dfile3 = "btree3" ;
+my $Dfile1 = "btree1" ;
+my $Dfile2 = "btree2" ;
+my $Dfile3 = "btree3" ;
  
-$dbh1 = new DB_File::BTREEINFO ;
-{ local $^W = 0 ;
-  $dbh1->{compare} = sub { $_[0] <=> $_[1] } ; }
+my $dbh1 = new DB_File::BTREEINFO ;
+$dbh1->{compare} = sub { 
+       no warnings 'numeric' ;
+       $_[0] <=> $_[1] } ; 
  
-$dbh2 = new DB_File::BTREEINFO ;
+my $dbh2 = new DB_File::BTREEINFO ;
 $dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
  
-$dbh3 = new DB_File::BTREEINFO ;
+my $dbh3 = new DB_File::BTREEINFO ;
 $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
  
  
-tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ;
+my (%g, %k);
+tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; 
 tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;
 tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;
  
-@Keys = qw( 0123 12 -1234 9 987654321 def  ) ;
-{ local $^W = 0 ;
-  @srt_1 = sort { $a <=> $b } @Keys ; }
+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) {
-    { local $^W = 0 ; 
-      $h{$_} = 1 ; }
+    $h{$_} = 1 ;
     $g{$_} = 1 ;
     $k{$_} = 1 ;
 }
@@ -566,6 +588,7 @@ unlink $Dfile1 ;
 
    package Another ;
 
+   use warnings ;
    use strict ;
 
    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
@@ -573,6 +596,7 @@ unlink $Dfile1 ;
 
    package SubDB ;
 
+   use warnings ;
    use strict ;
    use vars qw( @ISA @EXPORT) ;
 
@@ -656,6 +680,7 @@ EOM
 
 {
    # DBM Filter tests
+   use warnings ;
    use strict ;
    my (%h, $db) ;
    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
@@ -762,6 +787,7 @@ EOM
 {    
     # DBM Filter with a closure
 
+    use warnings ;
     use strict ;
     my (%h, $db) ;
 
@@ -824,6 +850,7 @@ EOM
 
 {
    # DBM Filter recursion detection
+   use warnings ;
    use strict ;
    my (%h, $db) ;
    unlink $Dfile;
@@ -852,6 +879,7 @@ EOM
     # BTREE example 1
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
 
@@ -904,6 +932,7 @@ EOM
     # BTREE example 2
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
 
@@ -955,6 +984,7 @@ EOM
     # BTREE example 3
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
  
@@ -1010,6 +1040,7 @@ EOM
     # BTREE example 4
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
  
@@ -1058,6 +1089,7 @@ EOM
     # BTREE example 5
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
  
@@ -1092,6 +1124,7 @@ EOM
     # BTREE example 6
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
  
@@ -1126,6 +1159,7 @@ EOM
     # BTREE example 7
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
     use Fcntl ;
@@ -1231,7 +1265,7 @@ EOM
     my $a = "";
     local $SIG{__WARN__} = sub {$a = $_[0]} ;
     
-    tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE 
+    tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
        or die "Can't open file: $!\n" ;
     $h{ABC} = undef;
     ok(156, $a eq "") ;
@@ -1239,4 +1273,24 @@ EOM
     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(157, $a eq "") ;
+    untie %h ;
+    unlink $Dfile;
+}
+
 exit ;

diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t
index 4627969..effc60b 100755 (executable)
--- a/t/lib/db-hash.t
+++ b/t/lib/db-hash.t
@@ -9,10 +9,12 @@ BEGIN {
     }
 }
 
+use strict;
+use warnings;
 use DB_File; 
 use Fcntl;
 
-print "1..110\n";
+print "1..111\n";
 
 sub ok
 {
@@ -57,6 +59,9 @@ sub docat_del
 }   
 
 my $Dfile = "dbhash.tmp";
+my $null_keys_allowed = ($DB_File::db_ver < 2.004010 
+                               || $DB_File::db_ver >= 3.1 );
+
 unlink $Dfile;
 
 umask(0);
@@ -98,13 +103,14 @@ 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 ) );
 
-($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
    $blksize,$blocks) = stat($Dfile);
 ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
 
+my ($key, $value, $i);
 while (($key,$value) = each(%h)) {
     $i++;
 }
@@ -176,8 +182,8 @@ $h{'goner3'} = 'snork';
 delete $h{'goner1'};
 $X->DELETE('goner3');
 
-@keys = keys(%h);
-@values = values(%h);
+my @keys = keys(%h);
+my @values = values(%h);
 
 ok(23, $#keys == 29 && $#values == 29) ;
 
@@ -197,14 +203,19 @@ ok(25, $#keys == 31) ;
 $h{'foo'} = '';
 ok(26, $h{'foo'} eq '' );
 
-# Berkeley DB 2 from version 2.4.10 onwards does not allow null keys.
-# This feature will be reenabled in a future version of Berkeley DB.
-#$h{''} = 'bar';
-#ok(27, $h{''} eq 'bar' );
-ok(27,1) ;
+# 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
-$ok = 1;
+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 );
@@ -214,7 +225,7 @@ ok(28, $ok );
 ok(29, $size > 0 );
 
 @h{0..200} = 200..400;
-@foo = @h{0..200};
+my @foo = @h{0..200};
 ok(30, join(':',200..400) eq join(':',@foo) );
 
 
@@ -223,7 +234,7 @@ ok(30, join(':',200..400) eq join(':',@foo) );
 # Check NOOVERWRITE will make put fail when attempting to overwrite
 # an existing record.
  
-$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
+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 
@@ -246,9 +257,10 @@ $status = $X->del('q') ;
 ok(36, $status == 0 );
 
 # Make sure that the key deleted, cannot be retrieved
-$^W = 0 ;
-ok(37, $h{'q'} eq undef );
-$^W = 1 ;
+{
+    no warnings 'uninitialized' ;
+    ok(37, $h{'q'} eq undef );
+}
 
 # Attempting to delete a non-existant key should fail
 
@@ -361,6 +373,7 @@ untie %h ;
 
    package Another ;
 
+   use warnings ;
    use strict ;
 
    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
@@ -368,6 +381,7 @@ untie %h ;
 
    package SubDB ;
 
+   use warnings ;
    use strict ;
    use vars qw( @ISA @EXPORT) ;
 
@@ -451,6 +465,7 @@ EOM
 
 {
    # DBM Filter tests
+   use warnings ;
    use strict ;
    my (%h, $db) ;
    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
@@ -557,6 +572,7 @@ EOM
 {    
     # DBM Filter with a closure
 
+    use warnings ;
     use strict ;
     my (%h, $db) ;
 
@@ -619,6 +635,7 @@ EOM
 
 {
    # DBM Filter recursion detection
+   use warnings ;
    use strict ;
    my (%h, $db) ;
    unlink $Dfile;
@@ -643,6 +660,7 @@ EOM
   {
     my $redirect = new Redirect $file ;
 
+    use warnings FATAL => qw(all);
     use strict ;
     use DB_File ;
     use vars qw( %h $k $v ) ;
@@ -699,7 +717,26 @@ EOM
     tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
     $h{ABC} = undef;
     ok(110, $a eq "") ;
-    untie %h;
+    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(111, $a eq "") ;
+    untie %h ;
     unlink $Dfile;
 }
 

diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t
index f932a89..8b5a88c 100755 (executable)
--- a/t/lib/db-recno.t
+++ b/t/lib/db-recno.t
@@ -12,6 +12,7 @@ BEGIN {
 use DB_File; 
 use Fcntl;
 use strict ;
+use warnings;
 use vars qw($dbh $Dfile $bad_ones $FA) ;
 
 # full tied array support started in Perl 5.004_57
@@ -99,7 +100,7 @@ sub bad_one
 EOM
 }
 
-print "1..127\n";
+print "1..128\n";
 
 my $Dfile = "recno.tmp";
 unlink $Dfile ;
@@ -340,6 +341,7 @@ unlink $Dfile;
 
    package Another ;
 
+   use warnings ;
    use strict ;
 
    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
@@ -347,6 +349,7 @@ unlink $Dfile;
 
    package SubDB ;
 
+   use warnings ;
    use strict ;
    use vars qw( @ISA @EXPORT) ;
 
@@ -487,6 +490,7 @@ EOM
 
 {
    # DBM Filter tests
+   use warnings ;
    use strict ;
    my (@h, $db) ;
    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
@@ -593,6 +597,7 @@ EOM
 {    
     # DBM Filter with a closure
 
+    use warnings ;
     use strict ;
     my (@h, $db) ;
 
@@ -655,6 +660,7 @@ EOM
 
 {
    # DBM Filter recursion detection
+   use warnings ;
    use strict ;
    my (@h, $db) ;
    unlink $Dfile;
@@ -679,6 +685,7 @@ EOM
   {
     my $redirect = new Redirect $file ;
 
+    use warnings FATAL => qw(all);
     use strict ;
     use DB_File ;
 
@@ -734,6 +741,7 @@ EOM
   {
     my $redirect = new Redirect $save_output ;
 
+    use warnings FATAL => qw(all);
     use strict ;
     use vars qw(@h $H $file $i) ;
     use DB_File ;
@@ -850,11 +858,31 @@ EOM
     my $a = "";
     local $SIG{__WARN__} = sub {$a = $_[0]} ;
     
-    tie @h, 'DB_File', $Dfile,  O_RDWR|O_CREAT, 0664, $DB_RECNO 
+    tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 
        or die "Can't open file: $!\n" ;
     $h[0] = undef;
     ok(127, $a eq "") ;
-    untie @h;
+    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 ;
+    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(128, $a eq "") ;
+    untie @h ;
     unlink $Dfile;
 }