RE: [PATCH] RE: DB_File breakage

   From: "Paul Marquess" <paul_marquess@yahoo.co.uk>
   Message-Id: <AIEAJICLCBDNAAOLLOKLIEJADOAA.paul_marquess@yahoo.co.uk>

p4raw-id: //depot/perl@14979

diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes
index 409f62f..3351542 100644 (file)
--- 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 (file)
--- 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 (executable)
--- 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'"