DB_File 1.809 was RE: [perl #30237] DB_File methods and substr don't mix

From: "Paul Marquess" <Paul.Marquess@btinternet.com>
Message-Id: <20040622202910.WBSU21846.mta08-svc.ntlworld.com@MARQUESSPT21>

p4raw-id: //depot/perl@22970

7 files changed, 424 insertions, 38 deletions

diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes
index 14a2ec0045..e74c3e2ac9 100644
--- a/ext/DB_File/Changes
+++ b/ext/DB_File/Changes
@@ -1,4 +1,16 @@
 
+
+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.
diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm
index b9fb63a224..3f53d468cd 100644
--- a/ext/DB_File/DB_File.pm
+++ b/ext/DB_File/DB_File.pm
@@ -1,10 +1,10 @@
 # DB_File.pm -- Perl 5 interface to Berkeley DB 
 #
 # written by Paul Marquess (pmqs@cpan.org)
-# last modified 22nd December 2003
-# version 1.808
+# last modified 20th June 2004
+# version 1.809
 #
-#     Copyright (c) 1995-2003 Paul Marquess. All rights reserved.
+#     Copyright (c) 1995-2004 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.
 
@@ -165,7 +165,7 @@ our ($db_version, $use_XSLoader, $splice_end_array);
 use Carp;
 
 
-$VERSION = "1.808_02" ;
+$VERSION = "1.809" ;
 
 {
     local $SIG{__WARN__} = sub {$splice_end_array = "@_";};
@@ -266,7 +266,8 @@ sub tie_hash_or_array
     $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 work like recno in version 1.
+    # make recno in Berkeley DB version 2 (or better) work like 
+    # recno in version 1.
     if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and 
 	$arg[1] and ! -e $arg[1]) {
 	open(FH, ">$arg[1]") or return undef ;
@@ -2252,7 +2253,7 @@ compile properly on IRIX 5.3.
 
 =head1 COPYRIGHT
 
-Copyright (c) 1995-2003 Paul Marquess. All rights reserved. This program
+Copyright (c) 1995-2004 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.
 
diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index fec250961d..eb83670338 100644
--- a/ext/DB_File/DB_File.xs
+++ b/ext/DB_File/DB_File.xs
@@ -3,12 +3,12 @@
  DB_File.xs -- Perl 5 interface to Berkeley DB 
 
  written by Paul Marquess <pmqs@cpan.org>
- last modified 22nd December 2003
- version 1.808
+ last modified 20th June 2004
+ version 1.809
 
  All comments/suggestions/problems are welcome
 
-     Copyright (c) 1995-2003 Paul Marquess. All rights reserved.
+     Copyright (c) 1995-2004 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.
 
@@ -108,6 +108,7 @@
         1.806 - recursion detection beefed up.
         1.807 - no change
         1.808 - leak fixed in ParseOpenInfo
+        1.809 - no change
 
 */
 
@@ -932,7 +933,10 @@ SV *   sv ;
     STRLEN	n_a;
     dMY_CXT;
 
-/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ;  */
+#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 */
diff --git a/ext/DB_File/t/db-btree.t b/ext/DB_File/t/db-btree.t
index 7dd544ad9f..deab41010e 100755
--- a/ext/DB_File/t/db-btree.t
+++ b/ext/DB_File/t/db-btree.t
@@ -34,7 +34,7 @@ EOM
 use DB_File; 
 use Fcntl;
 
-print "1..187\n";
+print "1..197\n";
 
 unlink glob "__db.*";
 
@@ -1535,4 +1535,124 @@ ok(165,1);
    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/ext/DB_File/t/db-hash.t b/ext/DB_File/t/db-hash.t
index f76a3a537c..86a64ff705 100755
--- a/ext/DB_File/t/db-hash.t
+++ b/ext/DB_File/t/db-hash.t
@@ -23,7 +23,7 @@ BEGIN {
 use DB_File; 
 use Fcntl;
 
-print "1..151\n";
+print "1..161\n";
 
 unlink glob "__db.*";
 
@@ -34,6 +34,8 @@ sub ok
  
     print "not " unless $result ;
     print "ok $no\n" ;
+
+    return $result ;
 }
 
 {
@@ -932,8 +934,10 @@ EOM
     tie %hash1, 'DB_File',$Dfile, undef;
     ok(133, $warn_count == 0);
     $warn_count = 0;
+    unlink $Dfile;
     tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef;
     ok(134, $warn_count == 0);
+    unlink $Dfile;
     tie %hash1, 'DB_File',$Dfile, undef, undef;
     ok(135, $warn_count == 0);
     $warn_count = 0;
@@ -1033,4 +1037,123 @@ EOM
    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($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 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 bron between versions 2.3.16 and 
+    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;
+}
+
 exit ;
diff --git a/ext/DB_File/t/db-recno.t b/ext/DB_File/t/db-recno.t
index 8bd637942f..23bf0cdec5 100755
--- a/ext/DB_File/t/db-recno.t
+++ b/ext/DB_File/t/db-recno.t
@@ -151,7 +151,7 @@ BEGIN
 }
 
 my $splice_tests = 10 + 12 + 1; # ten regressions, plus the randoms
-my $total_tests = 168 ;
+my $total_tests = 181 ;
 $total_tests += $splice_tests if $FA ;
 print "1..$total_tests\n";   
 
@@ -1060,6 +1060,129 @@ EOM
    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 ;
 
@@ -1087,36 +1210,36 @@ exit unless $FA ;
     my $offset ;
     $a = '';
     splice(@a, $offset);
-    ok(169, $a =~ /^Use of uninitialized value /);
+    ok(182, $a =~ /^Use of uninitialized value /);
     $a = '';
     splice(@tied, $offset);
-    ok(170, $a =~ /^Use of uninitialized value in splice/);
+    ok(183, $a =~ /^Use of uninitialized value in splice/);
 
     no warnings 'uninitialized';
     $a = '';
     splice(@a, $offset);
-    ok(171, $a eq '');
+    ok(184, $a eq '');
     $a = '';
     splice(@tied, $offset);
-    ok(172, $a eq '');
+    ok(185, $a eq '');
 
     # uninitialized length
     use warnings;
     my $length ;
     $a = '';
     splice(@a, 0, $length);
-    ok(173, $a =~ /^Use of uninitialized value /);
+    ok(186, $a =~ /^Use of uninitialized value /);
     $a = '';
     splice(@tied, 0, $length);
-    ok(174, $a =~ /^Use of uninitialized value in splice/);
+    ok(187, $a =~ /^Use of uninitialized value in splice/);
 
     no warnings 'uninitialized';
     $a = '';
     splice(@a, 0, $length);
-    ok(175, $a eq '');
+    ok(188, $a eq '');
     $a = '';
     splice(@tied, 0, $length);
-    ok(176, $a eq '');
+    ok(189, $a eq '');
 
     # offset past end of array
     use warnings;
@@ -1125,17 +1248,17 @@ exit unless $FA ;
     my $splice_end_array = ($a =~ /^splice\(\) offset past end of array/);
     $a = '';
     splice(@tied, 3);
-    ok(177, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/);
+    ok(190, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/);
 
     no warnings 'misc';
     $a = '';
     splice(@a, 3);
-    ok(178, $a eq '');
+    ok(191, $a eq '');
     $a = '';
     splice(@tied, 3);
-    ok(179, $a eq '');
+    ok(192, $a eq '');
 
-    ok(180, safeUntie \@tied);
+    ok(193, safeUntie \@tied);
     unlink $Dfile;
 }
 
@@ -1196,7 +1319,7 @@ my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion',
 	       'void' ],
 	    );
 
-my $testnum = 181;
+my $testnum = 194;
 my $failed = 0;
 my $tmp = "dbr$$";
 foreach my $test (@tests) {
diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap
index 4c9df9e3c0..f159995080 100644
--- 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 10th December 2000
-# version 1.74
+# last modified 20th June 2004
+# version 1.809
 #
 #################################### DB SECTION
 #
@@ -17,20 +17,23 @@ INPUT
 T_dbtkeydatum
 	DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
 	DBT_clear($var) ;
-	if (SvOK($arg)){
-	    if (db->type != DB_RECNO) {
-	        $var.data = SvPVbyte($arg, PL_na);
-	        $var.size = (int)PL_na;
-	    }
-	    else {
-	        Value =  GetRecnoKey(aTHX_ db, SvIV($arg)) ; 
-	        $var.data = & Value; 
-	        $var.size = (int)sizeof(recno_t);
-	    }
+	SvGETMAGIC($arg) ;
+        if (db->type == DB_RECNO) {
+	    if (SvOK($arg))
+	        Value = GetRecnoKey(aTHX_ db, SvIV($arg)) ; 
+            else
+	        Value = 1 ;
+	    $var.data = & Value; 
+	    $var.size = (int)sizeof(recno_t);
+        }
+        else if (SvOK($arg)) {
+	    $var.data = SvPVbyte($arg, PL_na);
+	    $var.size = (int)PL_na;
 	}
 T_dbtdatum
 	DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
 	DBT_clear($var) ;
+	SvGETMAGIC($arg) ;
 	if (SvOK($arg)) {
 	    $var.data = SvPVbyte($arg, PL_na);
 	    $var.size = (int)PL_na;