Integrate mainline - all tests pass - some noise from threads

av_simple (SuSE7.3).

p4raw-id: //depot/perlio@14992

4 files changed, 137 insertions, 15 deletions

diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index ec84a50db4..5a61a6dbd1 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -3043,6 +3043,41 @@ sub re_uninterp_extended {
 }
 }
 
+my %unctrl = # portable to to EBCDIC
+    (
+     "\c@" => '\c@',	# unused
+     "\cA" => '\cA',
+     "\cB" => '\cB',
+     "\cC" => '\cC',
+     "\cD" => '\cD',
+     "\cE" => '\cE',
+     "\cF" => '\cF',
+     "\cG" => '\cG',
+     "\cH" => '\cH',
+     "\cI" => '\cI',
+     "\cJ" => '\cJ',
+     "\cK" => '\cK',
+     "\cL" => '\cL',
+     "\cM" => '\cM',
+     "\cN" => '\cN',
+     "\cO" => '\cO',
+     "\cP" => '\cP',
+     "\cQ" => '\cQ',
+     "\cR" => '\cR',
+     "\cS" => '\cS',
+     "\cT" => '\cT',
+     "\cU" => '\cU',
+     "\cV" => '\cV',
+     "\cW" => '\cW',
+     "\cX" => '\cX',
+     "\cY" => '\cY',
+     "\cZ" => '\cZ',
+     "\c[" => '\c[',	# unused
+     "\c\\" => '\c\\',	# unused
+     "\c]" => '\c]',	# unused
+     "\c_" => '\c_',	# unused
+    );
+
 # character escapes, but not delimiters that might need to be escaped
 sub escape_str { # ASCII, UTF8
     my($str) = @_;
@@ -3054,7 +3089,7 @@ sub escape_str { # ASCII, UTF8
     $str =~ s/\e/\\e/g;
     $str =~ s/\f/\\f/g;
     $str =~ s/\r/\\r/g;
-    $str =~ s/([\cA-\cZ])/sprintf("\\c%c", ord('@') + ord($1))/ge;
+    $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
     $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
     return $str;
 }
diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes
index 409f62faa0..3351542eee 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 1e29090b23..df189eb1cd 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 f077252107..ae1a4554c4 100755
--- a/ext/DB_File/t/db-recno.t
+++ b/ext/DB_File/t/db-recno.t
@@ -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'"