SAVEINT(db->filtering) ; \
db->filtering = TRUE ; \
SAVESPTR(DEFSV) ; \
+ if (name[7] == 's') \
+ arg = newSVsv(arg); \
DEFSV = arg ; \
SvTEMP_off(arg) ; \
PUSHMARK(SP) ; \
PUTBACK ; \
FREETMPS ; \
LEAVE ; \
+ if (name[7] == 's'){ \
+ arg = sv_2mortal(arg); \
+ } \
+ SvOKp(arg); \
}
#if 1 /* for compatibility */
+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 &
# 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
use Carp;
-$VERSION = "1.807" ;
+$VERSION = "1.808" ;
{
local $SIG{__WARN__} = sub {$splice_end_array = "@_";};
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
=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
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
*/
my_sv_setpvn(arg, name.data, name.size) ; \
TAINT; \
SvTAINTED_on(arg); \
+ SvUTF8_off(arg); \
DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
} \
}
sv_setiv(arg, (I32)*(I32*)name.data - 1); \
TAINT; \
SvTAINTED_on(arg); \
+ SvUTF8_off(arg); \
DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \
} \
}
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
#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 ;
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 ;
use DB_File;
use Fcntl;
-print "1..177\n";
+print "1..187\n";
unlink glob "__db.*";
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 ;
use DB_File;
use Fcntl;
-print "1..143\n";
+print "1..151\n";
unlink glob "__db.*";
($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]", "")) ;
#
# 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
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;
$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;
}
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;
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 { }) ;
$_ = "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
$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 ;
}
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";
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 ;
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;
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;
}
'void' ],
);
-my $testnum = 171;
+my $testnum = 181;
my $failed = 0;
require POSIX; my $tmp = POSIX::tmpnam();
foreach my $test (@tests) {
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 {
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;
}
#
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
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
{
}
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 {
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 {
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
{
}
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 {
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 {