From: Paul Marquess Date: Tue, 22 Jun 2004 21:29:12 +0000 (+0100) Subject: DB_File 1.809 was RE: [perl #30237] DB_File methods and substr don't mix X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9c095db2b2b99b70926d6f45029789d614441504;p=p5sagit%2Fp5-mst-13.2.git DB_File 1.809 was RE: [perl #30237] DB_File methods and substr don't mix From: "Paul Marquess" Message-Id: <20040622202910.WBSU21846.mta08-svc.ntlworld.com@MARQUESSPT21> p4raw-id: //depot/perl@22970 --- diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes index 14a2ec0..e74c3e2 100644 --- a/ext/DB_File/Changes +++ b/ext/DB_File/Changes @@ -1,4 +1,16 @@ + +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. diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index b9fb63a..3f53d46 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,10 +1,10 @@ # 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. @@ -165,7 +165,7 @@ our ($db_version, $use_XSLoader, $splice_end_array); use Carp; -$VERSION = "1.808_02" ; +$VERSION = "1.809" ; { local $SIG{__WARN__} = sub {$splice_end_array = "@_";}; @@ -266,7 +266,8 @@ sub tie_hash_or_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 ; @@ -2252,7 +2253,7 @@ compile properly on IRIX 5.3. =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. diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index fec2509..eb83670 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,12 +3,12 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess - 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. @@ -108,6 +108,7 @@ 1.806 - recursion detection beefed up. 1.807 - no change 1.808 - leak fixed in ParseOpenInfo + 1.809 - no change */ @@ -932,7 +933,10 @@ SV * sv ; 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 */ diff --git a/ext/DB_File/t/db-btree.t b/ext/DB_File/t/db-btree.t index 7dd544a..deab410 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..187\n"; +print "1..197\n"; unlink glob "__db.*"; @@ -1535,4 +1535,124 @@ ok(165,1); 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 ; diff --git a/ext/DB_File/t/db-hash.t b/ext/DB_File/t/db-hash.t index f76a3a5..86a64ff 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..151\n"; +print "1..161\n"; unlink glob "__db.*"; @@ -34,6 +34,8 @@ sub ok print "not " unless $result ; print "ok $no\n" ; + + return $result ; } { @@ -932,8 +934,10 @@ EOM 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; @@ -1033,4 +1037,123 @@ EOM 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 ; diff --git a/ext/DB_File/t/db-recno.t b/ext/DB_File/t/db-recno.t index 8bd6379..23bf0cd 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 = 168 ; +my $total_tests = 181 ; $total_tests += $splice_tests if $FA ; print "1..$total_tests\n"; @@ -1060,6 +1060,129 @@ EOM 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 ; @@ -1087,36 +1210,36 @@ 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; @@ -1125,17 +1248,17 @@ exit unless $FA ; 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; } @@ -1196,7 +1319,7 @@ my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion', 'void' ], ); -my $testnum = 181; +my $testnum = 194; my $failed = 0; my $tmp = "dbr$$"; foreach my $test (@tests) { diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap index 4c9df9e..f159995 100644 --- a/ext/DB_File/typemap +++ b/ext/DB_File/typemap @@ -1,8 +1,8 @@ # typemap for Perl 5 interface to Berkeley # # written by Paul Marquess -# last modified 10th December 2000 -# version 1.74 +# last modified 20th June 2004 +# version 1.809 # #################################### DB SECTION # @@ -17,20 +17,23 @@ INPUT 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;