DB_File-1.79

Message-ID: <AIEAJICLCBDNAAOLLOKLAEELDDAA.paul.marquess@openwave.com>

p4raw-id: //depot/perl@12661

4 files changed, 480 insertions, 114 deletions

diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes
index da6af577cb..be6e6e3047 100644
--- a/ext/DB_File/Changes
+++ b/ext/DB_File/Changes
@@ -366,3 +366,11 @@
 
    * added documentation patch regarding duplicate keys from Andrew Johnson
 
+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.
diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index 05e5319b92..52c7670f9b 100644
--- 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 30th July 2001
- version 1.78
+ last modified 22nd Oct 2001
+ version 1.79
 
  All comments/suggestions/problems are welcome
 
@@ -93,6 +93,8 @@
         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
 
 */
 
@@ -412,7 +414,7 @@ typedef DBT DBTKEY ;
 #define ckFilter(arg,type,name)					\
 	if (db->type) {						\
 	    SV * save_defsv ;					\
-            /* printf("filtering %s\n", name) ;*/		\
+            /* printf("filtering %s\n", name) ; */ 		\
 	    if (db->filtering)					\
 	        croak("recursion detected in %s", name) ;	\
 	    db->filtering = TRUE ;				\
@@ -424,7 +426,7 @@ typedef DBT DBTKEY ;
 	    sv_setsv(DEFSV, save_defsv) ;			\
 	    SvREFCNT_dec(save_defsv) ;				\
 	    db->filtering = FALSE ;				\
-	    /*printf("end of filtering %s\n", name) ;*/		\
+	    /* printf("end of filtering %s\n", name) ; */ 	\
 	}
 
 #else
@@ -454,6 +456,7 @@ typedef DBT DBTKEY ;
 	  } 								\
 	}
 
+#define my_SvUV32(sv) ((u_int32_t)SvUV(sv))
 
 #ifdef CAN_PROTOTYPE
 extern void __getBerkeleyDBInfo(void);
@@ -1210,23 +1213,23 @@ SV *   sv ;
 
            svp = hv_fetch(action, "ffactor", 7, FALSE);
 	   if (svp)
-	       (void)dbp->set_h_ffactor(dbp, SvIV(*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, SvIV(*svp)) ;
+               (void)dbp->set_h_nelem(dbp, my_SvUV32(*svp)) ;
          
            svp = hv_fetch(action, "bsize", 5, FALSE);
 	   if (svp)
-               (void)dbp->set_pagesize(dbp, SvIV(*svp));
+               (void)dbp->set_pagesize(dbp, my_SvUV32(*svp));
            
            svp = hv_fetch(action, "cachesize", 9, FALSE);
 	   if (svp)
-               (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ;
+               (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
          
            svp = hv_fetch(action, "lorder", 6, FALSE);
 	   if (svp)
-               (void)dbp->set_lorder(dbp, SvIV(*svp)) ;
+               (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
 
            PrintHash(info) ; 
         }
@@ -1253,19 +1256,19 @@ SV *   sv ;
 
            svp = hv_fetch(action, "flags", 5, FALSE);
 	   if (svp)
-              (void)dbp->set_flags(dbp, (u_int32_t)SvIV(*svp)) ;
+	       (void)dbp->set_flags(dbp, my_SvUV32(*svp)) ;
    
            svp = hv_fetch(action, "cachesize", 9, FALSE);
 	   if (svp)
-               (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ;
+               (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
          
            svp = hv_fetch(action, "psize", 5, FALSE);
 	   if (svp)
-               (void)dbp->set_pagesize(dbp, SvIV(*svp)) ;
+               (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
          
            svp = hv_fetch(action, "lorder", 6, FALSE);
 	   if (svp)
-               (void)dbp->set_lorder(dbp, SvIV(*svp)) ;
+               (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
 
             PrintBtree(info) ;
          
@@ -1291,17 +1294,17 @@ SV *   sv ;
 
            svp = hv_fetch(action, "cachesize", 9, FALSE);
 	   if (svp) {
-               status = dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ;
+               status = dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
 	   }
          
            svp = hv_fetch(action, "psize", 5, FALSE);
 	   if (svp) {
-               status = dbp->set_pagesize(dbp, SvIV(*svp)) ;
+               status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
 	    }
          
            svp = hv_fetch(action, "lorder", 6, FALSE);
 	   if (svp) {
-               status = dbp->set_lorder(dbp, SvIV(*svp)) ;
+               status = dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
 	   }
 
 	    svp = hv_fetch(action, "bval", 4, FALSE);
@@ -1311,7 +1314,7 @@ SV *   sv ;
                 if (SvPOK(*svp))
 		    value = (int)*SvPV(*svp, n_a) ;
 		else
-		    value = SvIV(*svp) ;
+		    value = (int)SvIV(*svp) ;
 
 		if (fixed) {
 		    status = dbp->set_re_pad(dbp, value) ;
@@ -1325,7 +1328,7 @@ SV *   sv ;
 	   if (fixed) {
                svp = hv_fetch(action, "reclen", 6, FALSE);
 	       if (svp) {
-		   u_int32_t len =  (u_int32_t)SvIV(*svp) ;
+		   u_int32_t len =  my_SvUV32(*svp) ;
                    status = dbp->set_re_len(dbp, len) ;
 	       }    
 	   }
@@ -1344,10 +1347,10 @@ SV *   sv ;
 		name = NULL ;
          
 
-	    status = dbp->set_flags(dbp, DB_RENUMBER) ;
+	    status = dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ;
          
 		if (flags){
-	            (void)dbp->set_flags(dbp, flags) ;
+	            (void)dbp->set_flags(dbp, (u_int32_t)flags) ;
 		}
             PrintRecno(info) ;
         }
@@ -1356,7 +1359,7 @@ SV *   sv ;
     }
 
     {
-        int	 	Flags = 0 ;
+        u_int32_t 	Flags = 0 ;
         int		status ;
 
         /* Map 1.x flags to 3.x flags */
diff --git a/ext/DB_File/t/db-recno.t b/ext/DB_File/t/db-recno.t
index 813c47d477..8a225ce9b8 100755
--- a/ext/DB_File/t/db-recno.t
+++ b/ext/DB_File/t/db-recno.t
@@ -101,7 +101,10 @@ sub bad_one
 EOM
 }
 
-print "1..128\n";
+my $splice_tests = 10 + 1; # ten regressions, plus the randoms
+my $total_tests = 138 ;
+$total_tests += $splice_tests if $FA ;
+print "1..$total_tests\n";   
 
 my $Dfile = "recno.tmp";
 unlink $Dfile ;
@@ -220,7 +223,25 @@ ok(39, $h[6] eq "the") ;
 ok(40, $h[7] eq "array") ;
 ok(41, $h[8] eq $data[8]) ;
 
-# SPLICE
+# 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
 
@@ -230,22 +251,22 @@ foreach (@data)
 {
    $ok = 0, last if $_ ne $h[$j ++] ; 
 }
-ok(42, $ok );
+ok(52, $ok );
 
 # Neagtive subscripts
 
 # get the last element of the array
-ok(43, $h[-1] eq $data[-1] );
-ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] );
+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(45, $@ eq "" );
-ok(46, $h[0] eq "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(47, $@ =~ '^Modification of non-creatable array value attempted' );
+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.
@@ -260,14 +281,14 @@ unlink $Dfile;
 
     my @h = () ;
     my $dbh = new DB_File::RECNOINFO ;
-    ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+    ok(58, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
     $h[0] = "abc" ;
     $h[1] = "def" ;
     $h[3] = "ghi" ;
     untie @h ;
     my $x = docat($Dfile) ;
     unlink $Dfile;
-    ok(49, $x eq "abc\ndef\n\nghi\n") ;
+    ok(59, $x eq "abc\ndef\n\nghi\n") ;
 }
 
 {
@@ -276,7 +297,7 @@ unlink $Dfile;
     my @h = () ;
     my $dbh = new DB_File::RECNOINFO ;
     $dbh->{bval} = "-" ;
-    ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+    ok(60, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
     $h[0] = "abc" ;
     $h[1] = "def" ;
     $h[3] = "ghi" ;
@@ -285,7 +306,7 @@ unlink $Dfile;
     unlink $Dfile;
     my $ok = ($x eq "abc-def--ghi-") ;
     bad_one() unless $ok ;
-    ok(51, $ok) ;
+    ok(61, $ok) ;
 }
 
 {
@@ -295,7 +316,7 @@ unlink $Dfile;
     my $dbh = new DB_File::RECNOINFO ;
     $dbh->{flags} = R_FIXEDLEN ;
     $dbh->{reclen} = 5 ;
-    ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+    ok(62, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
     $h[0] = "abc" ;
     $h[1] = "def" ;
     $h[3] = "ghi" ;
@@ -304,7 +325,7 @@ unlink $Dfile;
     unlink $Dfile;
     my $ok = ($x eq "abc  def       ghi  ") ;
     bad_one() unless $ok ;
-    ok(53, $ok) ;
+    ok(63, $ok) ;
 }
 
 {
@@ -315,7 +336,7 @@ unlink $Dfile;
     $dbh->{flags} = R_FIXEDLEN ;
     $dbh->{bval} = "-" ;
     $dbh->{reclen} = 5 ;
-    ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+    ok(64, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
     $h[0] = "abc" ;
     $h[1] = "def" ;
     $h[3] = "ghi" ;
@@ -324,7 +345,7 @@ unlink $Dfile;
     unlink $Dfile;
     my $ok = ($x eq "abc--def-------ghi--") ;
     bad_one() unless $ok ;
-    ok(55, $ok) ;
+    ok(65, $ok) ;
 }
 
 {
@@ -333,7 +354,7 @@ unlink $Dfile;
     my $filename = "xyz" ;
     my %x ;
     eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ;
-    ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ;
+    ok(66, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ;
     unlink $filename ;
 }
 
@@ -400,31 +421,31 @@ EOM
 
     BEGIN { push @INC, '.'; } 
     eval 'use SubDB ; ';
-    main::ok(57, $@ eq "") ;
+    main::ok(67, $@ eq "") ;
     my @h ;
     my $X ;
     eval '
 	$X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO );
 	' ;
 
-    main::ok(58, $@ eq "") ;
+    main::ok(68, $@ eq "") ;
 
     my $ret = eval '$h[3] = 3 ; return $h[3] ' ;
-    main::ok(59, $@ eq "") ;
-    main::ok(60, $ret == 5) ;
+    main::ok(69, $@ eq "") ;
+    main::ok(70, $ret == 5) ;
 
     my $value = 0;
     $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ;
-    main::ok(61, $@ eq "") ;
-    main::ok(62, $ret == 10) ;
+    main::ok(71, $@ eq "") ;
+    main::ok(72, $ret == 10) ;
 
     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
-    main::ok(63, $@ eq "" ) ;
-    main::ok(64, $ret == 1) ;
+    main::ok(73, $@ eq "" ) ;
+    main::ok(74, $ret == 1) ;
 
     $ret = eval '$X->A_new_method(1) ' ;
-    main::ok(65, $@ eq "") ;
-    main::ok(66, $ret eq "[[11]]") ;
+    main::ok(75, $@ eq "") ;
+    main::ok(76, $ret eq "[[11]]") ;
 
     undef $X;
     untie(@h);
@@ -437,52 +458,52 @@ EOM
     # test $#
     my $self ;
     unlink $Dfile;
-    ok(67, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
+    ok(77, $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(68, $FA ? $#h == 3 : $self->length() == 4) ;
+    ok(78, $FA ? $#h == 3 : $self->length() == 4) ;
     undef $self ;
     untie @h ;
     my $x = docat($Dfile) ;
-    ok(69, $x eq "abc\ndef\nghi\njkl\n") ;
+    ok(79, $x eq "abc\ndef\nghi\njkl\n") ;
 
     # $# sets array to same length
-    ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+    ok(80, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
     if ($FA)
       { $#h = 3 }
     else 
       { $self->STORESIZE(4) }
-    ok(71, $FA ? $#h == 3 : $self->length() == 4) ;
+    ok(81, $FA ? $#h == 3 : $self->length() == 4) ;
     undef $self ;
     untie @h ;
     $x = docat($Dfile) ;
-    ok(72, $x eq "abc\ndef\nghi\njkl\n") ;
+    ok(82, $x eq "abc\ndef\nghi\njkl\n") ;
 
     # $# sets array to bigger
-    ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+    ok(83, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
     if ($FA)
       { $#h = 6 }
     else 
       { $self->STORESIZE(7) }
-    ok(74, $FA ? $#h == 6 : $self->length() == 7) ;
+    ok(84, $FA ? $#h == 6 : $self->length() == 7) ;
     undef $self ;
     untie @h ;
     $x = docat($Dfile) ;
-    ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ;
+    ok(85, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ;
 
     # $# sets array smaller
-    ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+    ok(86, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
     if ($FA)
       { $#h = 2 }
     else 
       { $self->STORESIZE(3) }
-    ok(77, $FA ? $#h == 2 : $self->length() == 3) ;
+    ok(87, $FA ? $#h == 2 : $self->length() == 3) ;
     undef $self ;
     untie @h ;
     $x = docat($Dfile) ;
-    ok(78, $x eq "abc\ndef\nghi\n") ;
+    ok(88, $x eq "abc\ndef\nghi\n") ;
 
     unlink $Dfile;
 
@@ -506,7 +527,7 @@ EOM
 	   $_ eq 'original' ;
    }
    
-   ok(79, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+   ok(89, $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 = $_ }) ;
@@ -517,17 +538,17 @@ EOM
 
    $h[0] = "joe" ;
    #                   fk   sk     fv   sv
-   ok(80, checkOutput( "", 0, "", "joe")) ;
+   ok(90, checkOutput( "", 0, "", "joe")) ;
 
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
-   ok(81, $h[0] eq "joe");
+   ok(91, $h[0] eq "joe");
    #                   fk  sk  fv    sv
-   ok(82, checkOutput( "", 0, "joe", "")) ;
+   ok(92, checkOutput( "", 0, "joe", "")) ;
 
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
-   ok(83, $db->FIRSTKEY() == 0) ;
+   ok(93, $db->FIRSTKEY() == 0) ;
    #                    fk     sk  fv  sv
-   ok(84, checkOutput( 0, "", "", "")) ;
+   ok(94, checkOutput( 0, "", "", "")) ;
 
    # replace the filters, but remember the previous set
    my ($old_fk) = $db->filter_fetch_key   
@@ -542,17 +563,17 @@ EOM
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
    $h[1] = "Joe" ;
    #                   fk   sk     fv    sv
-   ok(85, checkOutput( "", 2, "", "Jxe")) ;
+   ok(95, checkOutput( "", 2, "", "Jxe")) ;
 
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
-   ok(86, $h[1] eq "[Jxe]");
+   ok(96, $h[1] eq "[Jxe]");
    #                   fk   sk     fv    sv
-   ok(87, checkOutput( "", 2, "[Jxe]", "")) ;
+   ok(97, checkOutput( "", 2, "[Jxe]", "")) ;
 
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
-   ok(88, $db->FIRSTKEY() == 1) ;
+   ok(98, $db->FIRSTKEY() == 1) ;
    #                   fk   sk     fv    sv
-   ok(89, checkOutput( 1, "", "", "")) ;
+   ok(99, checkOutput( 1, "", "", "")) ;
    
    # put the original filters back
    $db->filter_fetch_key   ($old_fk);
@@ -562,15 +583,15 @@ EOM
 
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
    $h[0] = "joe" ;
-   ok(90, checkOutput( "", 0, "", "joe")) ;
+   ok(100, checkOutput( "", 0, "", "joe")) ;
 
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
-   ok(91, $h[0] eq "joe");
-   ok(92, checkOutput( "", 0, "joe", "")) ;
+   ok(101, $h[0] eq "joe");
+   ok(102, checkOutput( "", 0, "joe", "")) ;
 
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
-   ok(93, $db->FIRSTKEY() == 0) ;
-   ok(94, checkOutput( 0, "", "", "")) ;
+   ok(103, $db->FIRSTKEY() == 0) ;
+   ok(104, checkOutput( 0, "", "", "")) ;
 
    # delete the filters
    $db->filter_fetch_key   (undef);
@@ -580,15 +601,15 @@ EOM
 
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
    $h[0] = "joe" ;
-   ok(95, checkOutput( "", "", "", "")) ;
+   ok(105, checkOutput( "", "", "", "")) ;
 
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
-   ok(96, $h[0] eq "joe");
-   ok(97, checkOutput( "", "", "", "")) ;
+   ok(106, $h[0] eq "joe");
+   ok(107, checkOutput( "", "", "", "")) ;
 
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
-   ok(98, $db->FIRSTKEY() == 0) ;
-   ok(99, checkOutput( "", "", "", "")) ;
+   ok(108, $db->FIRSTKEY() == 0) ;
+   ok(109, checkOutput( "", "", "", "")) ;
 
    undef $db ;
    untie @h;
@@ -603,7 +624,7 @@ EOM
     my (@h, $db) ;
 
     unlink $Dfile;
-    ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+    ok(110, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
 
     my %result = () ;
 
@@ -627,32 +648,32 @@ EOM
     $_ = "original" ;
 
     $h[0] = "joe" ;
-    ok(101, $result{"store key"} eq "store key - 1: [0]");
-    ok(102, $result{"store value"} eq "store value - 1: [joe]");
-    ok(103, ! defined $result{"fetch key"} );
-    ok(104, ! defined $result{"fetch value"} );
-    ok(105, $_ eq "original") ;
-
-    ok(106, $db->FIRSTKEY() == 0 ) ;
-    ok(107, $result{"store key"} eq "store key - 1: [0]");
-    ok(108, $result{"store value"} eq "store value - 1: [joe]");
-    ok(109, $result{"fetch key"} eq "fetch key - 1: [0]");
-    ok(110, ! defined $result{"fetch value"} );
-    ok(111, $_ eq "original") ;
+    ok(111, $result{"store key"} eq "store key - 1: [0]");
+    ok(112, $result{"store value"} eq "store value - 1: [joe]");
+    ok(113, ! defined $result{"fetch key"} );
+    ok(114, ! defined $result{"fetch value"} );
+    ok(115, $_ eq "original") ;
+
+    ok(116, $db->FIRSTKEY() == 0 ) ;
+    ok(117, $result{"store key"} eq "store key - 1: [0]");
+    ok(118, $result{"store value"} eq "store value - 1: [joe]");
+    ok(119, $result{"fetch key"} eq "fetch key - 1: [0]");
+    ok(120, ! defined $result{"fetch value"} );
+    ok(121, $_ eq "original") ;
 
     $h[7]  = "john" ;
-    ok(112, $result{"store key"} eq "store key - 2: [0 7]");
-    ok(113, $result{"store value"} eq "store value - 2: [joe john]");
-    ok(114, $result{"fetch key"} eq "fetch key - 1: [0]");
-    ok(115, ! defined $result{"fetch value"} );
-    ok(116, $_ eq "original") ;
-
-    ok(117, $h[0] eq "joe");
-    ok(118, $result{"store key"} eq "store key - 3: [0 7 0]");
-    ok(119, $result{"store value"} eq "store value - 2: [joe john]");
-    ok(120, $result{"fetch key"} eq "fetch key - 1: [0]");
-    ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]");
-    ok(122, $_ eq "original") ;
+    ok(122, $result{"store key"} eq "store key - 2: [0 7]");
+    ok(123, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(124, $result{"fetch key"} eq "fetch key - 1: [0]");
+    ok(125, ! defined $result{"fetch value"} );
+    ok(126, $_ eq "original") ;
+
+    ok(127, $h[0] eq "joe");
+    ok(128, $result{"store key"} eq "store key - 3: [0 7 0]");
+    ok(129, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(130, $result{"fetch key"} eq "fetch key - 1: [0]");
+    ok(131, $result{"fetch value"} eq "fetch value - 1: [joe]");
+    ok(132, $_ eq "original") ;
 
     undef $db ;
     untie @h;
@@ -666,12 +687,12 @@ EOM
    my (@h, $db) ;
    unlink $Dfile;
 
-   ok(123, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+   ok(133, $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(124, $@ =~ /^recursion detected in filter_store_key at/ );
+   ok(134, $@ =~ /^recursion detected in filter_store_key at/ );
    
    undef $db ;
    untie @h;
@@ -729,7 +750,7 @@ EOM
     unlink $filename ;
   }  
 
-  ok(125, docat_del($file) eq <<'EOM') ;
+  ok(135, docat_del($file) eq <<'EOM') ;
 The array contains 5 entries
 popped black
 shifted white
@@ -814,7 +835,7 @@ EOM
     unlink $file ;
   }  
 
-  ok(126, docat_del($save_output) eq <<'EOM') ;
+  ok(136, docat_del($save_output) eq <<'EOM') ;
 
 ORIGINAL
 0: zero
@@ -862,7 +883,7 @@ EOM
     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 "") ;
+    ok(137, $a eq "") ;
     untie @h ;
     unlink $Dfile;
 }
@@ -882,9 +903,343 @@ EOM
     tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 
 	or die "Can't open file: $!\n" ;
     @h = (); ;
-    ok(128, $a eq "") ;
+    ok(138, $a eq "") ;
     untie @h ;
     unlink $Dfile;
 }
 
+# Only test splice if this is a newish version of Perl
+exit unless $FA ;
+
+# Test SPLICE
+# 
+# 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 = 139;
+my $failed = 0;
+require POSIX; my $tmp = POSIX::tmpnam();
+foreach my $test (@tests) {
+    my $err = test_splice(@$test);
+    if (defined $err) {
+	require Data::Dumper;
+	print STDERR "failed: ", Data::Dumper::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) {
+	    require Data::Dumper;
+	    print STDERR "failed: ", Data::Dumper::Dumper($test);
+	    print STDERR "error: $err\n";
+	    $failed = 1;
+	    print STDERR "skipping any remaining random tests\n";
+	    last;
+	}
+    }
+
+    ok($testnum++, not $failed);
+}
+
+die 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;
+
+    open(TEXT, ">$tmp") or die "cannot write to $tmp: $!";
+    foreach (@array) { print TEXT "$_\n" }
+    close TEXT or die "cannot close $tmp: $!";
+    
+    my @h;
+    my $H = tie @h, 'DB_File', $tmp, O_RDWR, 0644, $DB_RECNO
+      or die "cannot open $tmp: $!";
+    
+    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+\.$//;
+    }
+
+    # 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+ line \d+\.?$//;
+    }
+
+    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>; 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);
+
+    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/ext/DB_File/version.c b/ext/DB_File/version.c
index 48c29a0e6f..0997db1010 100644
--- a/ext/DB_File/version.c
+++ b/ext/DB_File/version.c
@@ -3,8 +3,8 @@
  version.c -- Perl 5 interface to Berkeley DB 
 
  written by Paul Marquess <Paul.Marquess@btinternet.com>
- last modified 30th July 2001
- version 1.78
+ last modified 22nd Oct 2001
+ version 1.79
 
  All comments/suggestions/problems are welcome