+
+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.
# 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.
use Carp;
-$VERSION = "1.808_02" ;
+$VERSION = "1.809" ;
{
local $SIG{__WARN__} = sub {$splice_end_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 ;
=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.
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.
1.806 - recursion detection beefed up.
1.807 - no change
1.808 - leak fixed in ParseOpenInfo
+ 1.809 - no change
*/
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 */
use DB_File;
use Fcntl;
-print "1..187\n";
+print "1..197\n";
unlink glob "__db.*";
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 ;
use DB_File;
use Fcntl;
-print "1..151\n";
+print "1..161\n";
unlink glob "__db.*";
print "not " unless $result ;
print "ok $no\n" ;
+
+ return $result ;
}
{
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;
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 ;
}
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";
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 ;
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;
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;
}
'void' ],
);
-my $testnum = 181;
+my $testnum = 194;
my $failed = 0;
my $tmp = "dbr$$";
foreach my $test (@tests) {
# 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
#
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;
projects / platform / upstream / perl.git / commitdiff