From: Paul Marquess Date: Sun, 3 Mar 2002 23:56:31 +0000 (+0000) Subject: RE: [PATCH] RE: DB_File breakage X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d85a743d827c8b55194ec4ce2b5b444749021b7e;p=p5sagit%2Fp5-mst-13.2.git RE: [PATCH] RE: DB_File breakage From: "Paul Marquess" Message-Id: p4raw-id: //depot/perl@14979 --- diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes index 409f62f..3351542 100644 --- a/ext/DB_File/Changes +++ b/ext/DB_File/Changes @@ -410,3 +410,8 @@ * FETCH, STORE & DELETE don't map the flags parameter into the equivalent Berkeley DB function anymore. +1.804 2nd March 2002 + + * Perl core patch 14939 added a new warning to "splice". This broke the + db-recno test harness. Fixed. + diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 1e29090..df189eb 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -2,7 +2,7 @@ # # written by Paul Marquess (Paul.Marquess@btinternet.com) # last modified 1st March 2002 -# version 1.803 +# version 1.804 # # Copyright (c) 1995-2002 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or @@ -146,11 +146,18 @@ package DB_File ; use warnings; use strict; our ($VERSION, @ISA, @EXPORT, $AUTOLOAD, $DB_BTREE, $DB_HASH, $DB_RECNO); -our ($db_version, $use_XSLoader); +our ($db_version, $use_XSLoader, $splice_end_array); use Carp; -$VERSION = "1.803" ; +$VERSION = "1.804" ; + +{ + local $SIG{__WARN__} = sub {$splice_end_array = "@_";}; + my @a =(1); splice(@a, 3); + $splice_end_array = + ($splice_end_array =~ /^splice\(\) offset past end of array at /); +} #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; @@ -303,7 +310,7 @@ sub SPLICE my $self = shift; my $offset = shift; if (not defined $offset) { - carp 'Use of uninitialized value in splice'; + warnings::warnif('uninitialized', 'Use of uninitialized value in splice'); $offset = 0; } @@ -328,15 +335,17 @@ sub SPLICE $offset = $new_offset; } - if ($offset > $size) { - $offset = $size; - } - if (not defined $length) { - carp 'Use of uninitialized value in splice'; + warnings::warnif('uninitialized', 'Use of uninitialized value in splice'); $length = 0; } + if ($offset > $size) { + $offset = $size; + warnings::warnif('misc', 'splice() offset past end of array') + if $splice_end_array; + } + # 'If LENGTH is omitted, removes everything from OFFSET onward.' if (not defined $length) { $length = $size - $offset; diff --git a/ext/DB_File/t/db-recno.t b/ext/DB_File/t/db-recno.t index f077252..0fd11d4 100755 --- a/ext/DB_File/t/db-recno.t +++ b/ext/DB_File/t/db-recno.t @@ -14,7 +14,7 @@ use Config; BEGIN { if(-d "lib" && -f "TEST") { if ($Config{'extensions'} !~ /\bDB_File\b/ ) { - print "1..0 # Skip: DB_File was not built\n"; + print "1..160 # Skip: DB_File was not built\n"; exit 0; } } @@ -126,7 +126,7 @@ BEGIN } } -my $splice_tests = 10 + 1; # ten regressions, plus the randoms +my $splice_tests = 10 + 11 + 1; # ten regressions, 11 warnings, plus the randoms my $total_tests = 138 ; $total_tests += $splice_tests if $FA ; print "1..$total_tests\n"; @@ -940,6 +940,81 @@ EOM exit unless $FA ; # Test SPLICE + +{ + # check that the splice warnings are under the same lexical control + # as their non-tied counterparts. + + use warnings; + use strict; + + my $a = ''; + my @a = (1); + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + unlink $Dfile; + my @tied ; + + tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + + # uninitialized offset + use warnings; + my $offset ; + $a = ''; + splice(@a, $offset); + ok(139, $a =~ /^Use of uninitialized value /); + $a = ''; + splice(@tied, $offset); + ok(140, $a =~ /^Use of uninitialized value in splice/); + + no warnings 'uninitialized'; + $a = ''; + splice(@a, $offset); + ok(141, $a eq ''); + $a = ''; + splice(@tied, $offset); + ok(142, $a eq ''); + + # uninitialized length + use warnings; + my $length ; + $a = ''; + splice(@a, 0, $length); + ok(143, $a =~ /^Use of uninitialized value /); + $a = ''; + splice(@tied, 0, $length); + ok(144, $a =~ /^Use of uninitialized value in splice/); + + no warnings 'uninitialized'; + $a = ''; + splice(@a, 0, $length); + ok(145, $a eq ''); + $a = ''; + splice(@tied, 0, $length); + ok(146, $a eq ''); + + # offset past end of array + use warnings; + $a = ''; + splice(@a, 3); + my $splice_end_array = ($a =~ /^splice\(\) offset past end of array/); + $a = ''; + splice(@tied, 3); + ok(147, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/); + + no warnings 'misc'; + $a = ''; + splice(@a, 3); + ok(148, $a eq ''); + $a = ''; + splice(@tied, 3); + ok(149, $a eq ''); + + untie @tied; + unlink $Dfile; +} + # # These are a few regression tests: bundles of five arguments to pass # to test_splice(). The first four arguments correspond to those @@ -997,7 +1072,7 @@ my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion', 'void' ], ); -my $testnum = 139; +my $testnum = 150; my $failed = 0; require POSIX; my $tmp = POSIX::tmpnam(); foreach my $test (@tests) { @@ -1080,7 +1155,6 @@ sub test_splice { my ($s_r, $s_error, @s_warnings); my $gather_warning = sub { push @s_warnings, $_[0] }; - $offset = $#array if $offset and $offset > @array; if ($context eq 'list') { my @r; eval { @@ -1119,7 +1193,6 @@ sub test_splice { # Now do the same for DB_File's version of splice my ($ms_r, $ms_error, @ms_warnings); $gather_warning = sub { push @ms_warnings, $_[0] }; - $offset = $#h if $offset and $offset > @h; if ($context eq 'list') { my @r; eval { @@ -1152,7 +1225,7 @@ sub test_splice { foreach ($ms_error, @ms_warnings) { chomp; - s/ at \S+ line \d+\.?$//; + s/ at \S+ line \d+\.?.*//s; } return "different errors: '$s_error' vs '$ms_error'"