From: Paul Marquess Date: Sat, 27 Dec 2003 20:02:30 +0000 (+0000) Subject: PATCH: *DB*_File X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5bbd4290dc068a04b65fb118bd01be1ae58c7454;p=p5sagit%2Fp5-mst-13.2.git PATCH: *DB*_File From: "Paul Marquess" Message-ID: p4raw-id: //depot/perl@21981 --- diff --git a/XSUB.h b/XSUB.h index af42f9c..b4c241a 100644 --- a/XSUB.h +++ b/XSUB.h @@ -267,6 +267,8 @@ C. See L. 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. See L. PUTBACK ; \ FREETMPS ; \ LEAVE ; \ + if (name[7] == 's'){ \ + arg = sv_2mortal(arg); \ + } \ + SvOKp(arg); \ } #if 1 /* for compatibility */ diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes index 848d26a..14a2ec0 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 54e0b52..77ba6cc 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 comes with the standard Perl source distribution. Look in the directory F. 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 for details), in the directory +L for details), in the directory F. This version of B 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, L, L, L, L, -L +L, L, L, L, L, +L =head1 AUTHOR The DB_File interface was written by Paul Marquess -Epmqs@cpan.org. +Epmqs@cpan.orgE. Questions about the DB system itself may be addressed to -Edb@sleepycat.com. +Edb@sleepycat.comE. =cut diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index 3f097de..fec2509 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 - 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 643e8fb..7dd544a 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 5f687a7..f76a3a5 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 f2cd97b..a2e78a1 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 8ad7b12..4c9df9e 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; } diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap index 048f0dd..8c7cb45 100644 --- a/ext/GDBM_File/typemap +++ b/ext/GDBM_File/typemap @@ -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 { diff --git a/ext/NDBM_File/typemap b/ext/NDBM_File/typemap index 093c426..c88725b 100644 --- a/ext/NDBM_File/typemap +++ b/ext/NDBM_File/typemap @@ -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 { diff --git a/ext/ODBM_File/typemap b/ext/ODBM_File/typemap index 4f4802c..cbc89b0 100644 --- a/ext/ODBM_File/typemap +++ b/ext/ODBM_File/typemap @@ -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 { diff --git a/ext/SDBM_File/typemap b/ext/SDBM_File/typemap index 093c426..c88725b 100644 --- a/ext/SDBM_File/typemap +++ b/ext/SDBM_File/typemap @@ -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 {