PATCH: *DB*_File

From: "Paul Marquess" <Paul.Marquess@btinternet.com>
Message-ID: <AIEAJICLCBDNAAOLLOKLIEAOPGAA.Paul.Marquess@btinternet.com>

p4raw-id: //depot/perl@21981

7 files changed, 201 insertions, 50 deletions

diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes
index 848d26a853..14a2ec0045 100644
--- a/ext/DB_File/Changes
+++ b/ext/DB_File/Changes
@@ -1,4 +1,11 @@
 
+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 &
diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm
index 54e0b527b3..77ba6ccf14 100644
--- 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 (pmqs@cpan.org)
-# last modified 22nd October 2002
-# version 1.807
+# last modified 22nd December 2003
+# version 1.808
 #
 #     Copyright (c) 1995-2003 Paul Marquess. All rights reserved.
 #     This program is free software; you can redistribute it and/or
@@ -165,7 +165,7 @@ our ($db_version, $use_XSLoader, $splice_end_array);
 use Carp;
 
 
-$VERSION = "1.807" ;
+$VERSION = "1.808" ;
 
 {
     local $SIG{__WARN__} = sub {$splice_end_array = "@_";};
@@ -2233,7 +2233,7 @@ B<DB_File> comes with the standard Perl source distribution. Look in
 the directory F<ext/DB_File>. Given the amount of time between releases
 of Perl the version that ships with Perl is quite likely to be out of
 date, so the most recent version can always be found on CPAN (see
-L<perlmod/CPAN> for details), in the directory
+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
@@ -2278,14 +2278,14 @@ Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details.
 
 =head1 SEE ALSO
 
-L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>,
-L<dbmfilter>
+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.org<gt>.
+E<lt>pmqs@cpan.orgE<gt>.
 Questions about the DB system itself may be addressed to
-E<lt>db@sleepycat.com<gt>.
+E<lt>db@sleepycat.comE<gt>.
 
 =cut
diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index 3f097de8dd..fec250961d 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 <pmqs@cpan.org>
- last modified 22nd October 2002
- version 1.807
+ last modified 22nd December 2003
+ version 1.808
 
  All comments/suggestions/problems are welcome
 
@@ -107,6 +107,7 @@
                 Filter code can now cope with read-only $_
         1.806 - recursion detection beefed up.
         1.807 - no change
+        1.808 - leak fixed in ParseOpenInfo
 
 */
 
@@ -398,6 +399,7 @@ typedef DBT DBTKEY ;
 	      my_sv_setpvn(arg, name.data, name.size) ;			\
 	      TAINT;                                       	\
 	      SvTAINTED_on(arg);                                       	\
+	      SvUTF8_off(arg);                                       	\
 	      DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; 	\
 	  }								\
 	}
@@ -412,6 +414,7 @@ typedef DBT DBTKEY ;
 		    sv_setiv(arg, (I32)*(I32*)name.data - 1); 		\
 	      TAINT;                                       	\
 	      SvTAINTED_on(arg);                                       	\
+	      SvUTF8_off(arg);                                       	\
 	      DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; 	\
 	  } 								\
 	}
@@ -1489,8 +1492,10 @@ db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_H
 	        sv = ST(5) ;
 
 	    RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
-	    if (RETVAL->dbp == NULL)
+	    if (RETVAL->dbp == NULL) {
+	        Safefree(RETVAL);
 	        RETVAL = NULL ;
+	    }
 	}
 	OUTPUT:	
 	    RETVAL
@@ -1653,7 +1658,8 @@ unshift(db, ...)
 #endif
 	    for (i = items-1 ; i > 0 ; --i)
 	    {
-	        value.data = SvPV(ST(i), n_a) ;
+		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 ;
@@ -1762,7 +1768,8 @@ push(db, ...)
 		    keyval = 0 ;
 	        for (i = 1 ; i < items ; ++i)
 	        {
-	            value.data = SvPV(ST(i), n_a) ;
+		    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 ;
diff --git a/ext/DB_File/t/db-btree.t b/ext/DB_File/t/db-btree.t
index 643e8fba5b..7dd544ad9f 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..177\n";
+print "1..187\n";
 
 unlink glob "__db.*";
 
@@ -1490,4 +1490,49 @@ ok(165,1);
    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;
+}
 exit ;
diff --git a/ext/DB_File/t/db-hash.t b/ext/DB_File/t/db-hash.t
index 5f687a75dd..f76a3a537c 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..143\n";
+print "1..151\n";
 
 unlink glob "__db.*";
 
@@ -580,7 +580,8 @@ EOM
    ($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") ;
+   ok(75, $k eq "Fred") ;
+    #print "k [$k]\n" ;
    ok(76, $v eq "[Jxe]") ;
    #                   fk   sk     fv    sv
    ok(77, checkOutput( "FRED", "fred", "[Jxe]", "")) ;
@@ -874,14 +875,14 @@ EOM
 #
 #    ok(128, $@ =~ /^DB_File hash callback: recursion detected/);
 #    {
-#        no warnings;
+#        local ($^W) = 0; #no warnings;
 #        untie %hash;
 #    }
 #    unlink $Dfile;
 #}
 
-ok(127,1);
-ok(128,1);
+#ok(127,1);
+#ok(128,1);
 
 {
     # Check that two hash's don't interact
@@ -899,8 +900,8 @@ ok(128,1);
  
  
     my (%h);
-    ok(129, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) );
-    ok(130, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) );
+    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;
@@ -910,11 +911,11 @@ ok(128,1);
     $hash2{xyz} = 2;
     $hash2{abcde} = 5;
 
-    ok(131, $h1_count > 0);
-    ok(132, $h1_count == $h2_count);
+    ok(129, $h1_count > 0);
+    ok(130, $h1_count == $h2_count);
 
-    ok(133, safeUntie \%hash1);
-    ok(134, safeUntie \%hash2);
+    ok(131, safeUntie \%hash1);
+    ok(132, safeUntie \%hash2);
     unlink $Dfile, $Dfile2;
 }
 
@@ -929,12 +930,12 @@ ok(128,1);
     unlink $Dfile;
 
     tie %hash1, 'DB_File',$Dfile, undef;
-    ok(135, $warn_count == 0);
+    ok(133, $warn_count == 0);
     $warn_count = 0;
     tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef;
-    ok(136, $warn_count == 0);
+    ok(134, $warn_count == 0);
     tie %hash1, 'DB_File',$Dfile, undef, undef;
-    ok(137, $warn_count == 0);
+    ok(135, $warn_count == 0);
     $warn_count = 0;
 
     untie %hash1;
@@ -950,7 +951,7 @@ ok(128,1);
    my $Dfile = "xxy.db";
    unlink $Dfile;
 
-   ok(138, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+   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 { }) ;
@@ -960,10 +961,10 @@ ok(128,1);
    $_ = "original" ;
 
    $h{"fred"} = "joe" ;
-   ok(139, $h{"fred"} eq "joe");
+   ok(137, $h{"fred"} eq "joe");
 
    eval { grep { $h{$_} } (1, 2, 3) };
-   ok (140, ! $@);
+   ok (138, ! $@);
 
 
    # delete the filters
@@ -974,17 +975,62 @@ ok(128,1);
 
    $h{"fred"} = "joe" ;
 
-   ok(141, $h{"fred"} eq "joe");
+   ok(139, $h{"fred"} eq "joe");
 
-   ok(142, $db->FIRSTKEY() eq "fred") ;
+   ok(140, $db->FIRSTKEY() eq "fred") ;
    
    eval { grep { $h{$_} } (1, 2, 3) };
-   ok (143, ! $@);
+   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;
+}
 
 exit ;
diff --git a/ext/DB_File/t/db-recno.t b/ext/DB_File/t/db-recno.t
index f2cd97bbf1..a2e78a1ea8 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 = 158 ;
+my $total_tests = 168 ;
 $total_tests += $splice_tests if $FA ;
 print "1..$total_tests\n";   
 
@@ -1014,6 +1014,52 @@ EOM
    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;
+}
+
 # Only test splice if this is a newish version of Perl
 exit unless $FA ;
 
@@ -1041,36 +1087,36 @@ exit unless $FA ;
     my $offset ;
     $a = '';
     splice(@a, $offset);
-    ok(159, $a =~ /^Use of uninitialized value /);
+    ok(169, $a =~ /^Use of uninitialized value /);
     $a = '';
     splice(@tied, $offset);
-    ok(160, $a =~ /^Use of uninitialized value in splice/);
+    ok(170, $a =~ /^Use of uninitialized value in splice/);
 
     no warnings 'uninitialized';
     $a = '';
     splice(@a, $offset);
-    ok(161, $a eq '');
+    ok(171, $a eq '');
     $a = '';
     splice(@tied, $offset);
-    ok(162, $a eq '');
+    ok(172, $a eq '');
 
     # uninitialized length
     use warnings;
     my $length ;
     $a = '';
     splice(@a, 0, $length);
-    ok(163, $a =~ /^Use of uninitialized value /);
+    ok(173, $a =~ /^Use of uninitialized value /);
     $a = '';
     splice(@tied, 0, $length);
-    ok(164, $a =~ /^Use of uninitialized value in splice/);
+    ok(174, $a =~ /^Use of uninitialized value in splice/);
 
     no warnings 'uninitialized';
     $a = '';
     splice(@a, 0, $length);
-    ok(165, $a eq '');
+    ok(175, $a eq '');
     $a = '';
     splice(@tied, 0, $length);
-    ok(166, $a eq '');
+    ok(176, $a eq '');
 
     # offset past end of array
     use warnings;
@@ -1079,17 +1125,17 @@ exit unless $FA ;
     my $splice_end_array = ($a =~ /^splice\(\) offset past end of array/);
     $a = '';
     splice(@tied, 3);
-    ok(167, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/);
+    ok(177, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/);
 
     no warnings 'misc';
     $a = '';
     splice(@a, 3);
-    ok(168, $a eq '');
+    ok(178, $a eq '');
     $a = '';
     splice(@tied, 3);
-    ok(169, $a eq '');
+    ok(179, $a eq '');
 
-    ok(170, safeUntie \@tied);
+    ok(180, safeUntie \@tied);
     unlink $Dfile;
 }
 
@@ -1150,7 +1196,7 @@ my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion',
 	       'void' ],
 	    );
 
-my $testnum = 171;
+my $testnum = 181;
 my $failed = 0;
 require POSIX; my $tmp = POSIX::tmpnam();
 foreach my $test (@tests) {
diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap
index 8ad7b1282d..4c9df9e3c0 100644
--- a/ext/DB_File/typemap
+++ b/ext/DB_File/typemap
@@ -19,7 +19,7 @@ T_dbtkeydatum
 	DBT_clear($var) ;
 	if (SvOK($arg)){
 	    if (db->type != DB_RECNO) {
-	        $var.data = SvPV($arg, PL_na);
+	        $var.data = SvPVbyte($arg, PL_na);
 	        $var.size = (int)PL_na;
 	    }
 	    else {
@@ -32,7 +32,7 @@ T_dbtdatum
 	DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
 	DBT_clear($var) ;
 	if (SvOK($arg)) {
-	    $var.data = SvPV($arg, PL_na);
+	    $var.data = SvPVbyte($arg, PL_na);
 	    $var.size = (int)PL_na;
 	}