PATCH: *DB*_File
Paul Marquess [Sat, 27 Dec 2003 20:02:30 +0000 (20:02 +0000)]
From: "Paul Marquess" <Paul.Marquess@btinternet.com>
Message-ID: <AIEAJICLCBDNAAOLLOKLIEAOPGAA.Paul.Marquess@btinternet.com>

p4raw-id: //depot/perl@21981

12 files changed:
XSUB.h
ext/DB_File/Changes
ext/DB_File/DB_File.pm
ext/DB_File/DB_File.xs
ext/DB_File/t/db-btree.t
ext/DB_File/t/db-hash.t
ext/DB_File/t/db-recno.t
ext/DB_File/typemap
ext/GDBM_File/typemap
ext/NDBM_File/typemap
ext/ODBM_File/typemap
ext/SDBM_File/typemap

diff --git a/XSUB.h b/XSUB.h
index af42f9c..b4c241a 100644 (file)
--- a/XSUB.h
+++ b/XSUB.h
@@ -267,6 +267,8 @@ C<xsubpp>.  See L<perlxs/"The VERSIONCHECK: Keyword">.
            SAVEINT(db->filtering) ;                            \
            db->filtering = TRUE ;                              \
            SAVESPTR(DEFSV) ;                                   \
+            if (name[7] == 's')                                 \
+                arg = newSVsv(arg);                             \
            DEFSV = arg ;                                       \
            SvTEMP_off(arg) ;                                   \
            PUSHMARK(SP) ;                                      \
@@ -276,6 +278,10 @@ C<xsubpp>.  See L<perlxs/"The VERSIONCHECK: Keyword">.
            PUTBACK ;                                           \
            FREETMPS ;                                          \
            LEAVE ;                                             \
+            if (name[7] == 's'){                                \
+                arg = sv_2mortal(arg);                          \
+            }                                                   \
+            SvOKp(arg);                                         \
        }
 
 #if 1          /* for compatibility */
index 848d26a..14a2ec0 100644 (file)
@@ -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 &
index 54e0b52..77ba6cc 100644 (file)
@@ -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
index 3f097de..fec2509 100644 (file)
@@ -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
 
                 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 ;
index 643e8fb..7dd544a 100755 (executable)
@@ -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 ;
index 5f687a7..f76a3a5 100755 (executable)
@@ -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 ;
index f2cd97b..a2e78a1 100755 (executable)
@@ -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) {
index 8ad7b12..4c9df9e 100644 (file)
@@ -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;
        }
 
index 048f0dd..8c7cb45 100644 (file)
@@ -3,7 +3,7 @@
 #
 
 datum_key              T_DATUM_K
-datum_key_copy         T_DATUM_K_C
+datum_key_copy         T_DATUM_K
 datum_value            T_DATUM_V
 NDBM_File              T_PTROBJ
 GDBM_File              T_PTROBJ
@@ -16,7 +16,7 @@ FATALFUNC             T_OPAQUEPTR
 INPUT
 T_DATUM_K
        DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
-       $var.dptr = SvPV($arg, PL_na);
+       $var.dptr = SvPVbyte($arg, PL_na);
        $var.dsize = (int)PL_na;
 T_DATUM_K_C
        {
@@ -27,13 +27,13 @@ T_DATUM_K_C
             }
             else
                 tmpSV = $arg;
-           $var.dptr = SvPV(tmpSV, PL_na);
+           $var.dptr = SvPVbyte(tmpSV, PL_na);
            $var.dsize = (int)PL_na;
        }
 T_DATUM_V
         DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
        if (SvOK($arg)) {
-           $var.dptr = SvPV($arg, PL_na);
+           $var.dptr = SvPVbyte($arg, PL_na);
            $var.dsize = (int)PL_na;
        }
        else {
index 093c426..c88725b 100644 (file)
@@ -16,12 +16,12 @@ FATALFUNC           T_OPAQUEPTR
 INPUT
 T_DATUM_K
        DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
-       $var.dptr = SvPV($arg, PL_na);
+       $var.dptr = SvPVbyte($arg, PL_na);
        $var.dsize = (int)PL_na;
 T_DATUM_V
         DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
        if (SvOK($arg)) {
-           $var.dptr = SvPV($arg, PL_na);
+           $var.dptr = SvPVbyte($arg, PL_na);
            $var.dsize = (int)PL_na;
        }
        else {
index 4f4802c..cbc89b0 100644 (file)
@@ -17,7 +17,7 @@ FATALFUNC             T_OPAQUEPTR
 INPUT
 T_DATUM_K
        DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
-       $var.dptr = SvPV($arg, PL_na);
+       $var.dptr = SvPVbyte($arg, PL_na);
        $var.dsize = (int)PL_na;
 T_DATUM_K_C
        {
@@ -28,13 +28,13 @@ T_DATUM_K_C
            }
            else
                tmpSV = $arg;
-           $var.dptr = SvPV(tmpSV, PL_na);
+           $var.dptr = SvPVbyte(tmpSV, PL_na);
            $var.dsize = (int)PL_na;
        }
 T_DATUM_V
         DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
        if (SvOK($arg)) {
-           $var.dptr = SvPV($arg, PL_na);
+           $var.dptr = SvPVbyte($arg, PL_na);
            $var.dsize = (int)PL_na;
        }
        else {
index 093c426..c88725b 100644 (file)
@@ -16,12 +16,12 @@ FATALFUNC           T_OPAQUEPTR
 INPUT
 T_DATUM_K
        DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
-       $var.dptr = SvPV($arg, PL_na);
+       $var.dptr = SvPVbyte($arg, PL_na);
        $var.dsize = (int)PL_na;
 T_DATUM_V
         DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
        if (SvOK($arg)) {
-           $var.dptr = SvPV($arg, PL_na);
+           $var.dptr = SvPVbyte($arg, PL_na);
            $var.dsize = (int)PL_na;
        }
        else {