Vendor import Perl 5.6.1

27 files changed, 1815 insertions, 422 deletions

diff --git a/contrib/perl5/t/pragma/constant.t b/contrib/perl5/t/pragma/constant.t
index 6438332cff2e..6e6617b70191 100755
--- a/contrib/perl5/t/pragma/constant.t
+++ b/contrib/perl5/t/pragma/constant.t
@@ -2,7 +2,7 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    unshift @INC, '../lib' if -d '../lib';
+    @INC = '../lib';
 }
 
 use warnings;
diff --git a/contrib/perl5/t/pragma/diagnostics.t b/contrib/perl5/t/pragma/diagnostics.t
index 15cd6b59276a..14014f6b6849 100755
--- a/contrib/perl5/t/pragma/diagnostics.t
+++ b/contrib/perl5/t/pragma/diagnostics.t
@@ -1,8 +1,8 @@
 #!./perl
 
 BEGIN {
-    chdir '..' if -d '../pod';
-    unshift @INC, './lib' if -d './lib';
+    chdir '..' if -d '../pod' && -d '../t';
+    @INC = 'lib';
 }
 
 
diff --git a/contrib/perl5/t/pragma/locale.t b/contrib/perl5/t/pragma/locale.t
index 414ceffe96ac..068fedeac818 100755
--- a/contrib/perl5/t/pragma/locale.t
+++ b/contrib/perl5/t/pragma/locale.t
@@ -2,7 +2,7 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    unshift @INC, '../lib';
+    @INC = '../lib';
     unshift @INC, '.';
     require Config; import Config;
     if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) {
@@ -15,8 +15,18 @@ use strict;
 
 my $debug = 1;
 
+use Dumpvalue;
+
+my $dumper = Dumpvalue->new(
+                            tick => qq{"},
+                            quoteHighBit => 0,
+                            unctrl => "quote"
+                           );
 sub debug {
-    print @_ if $debug;
+  return unless $debug;
+  my($mess) = join "", @_;
+  chop $mess;
+  print $dumper->stringify($mess,1), "\n";
 }
 
 sub debugf {
@@ -34,7 +44,9 @@ eval {
 # and mingw32 uses said silly CRT
 $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i;
 
-print "1..", ($have_setlocale ? 116 : 98), "\n";
+my $last = $have_setlocale ? 116 : 98;
+
+print "1..$last\n";
 
 use vars qw(&LC_ALL);
 
@@ -242,13 +254,13 @@ Afrikaans:af:za:1 15
 Arabic:ar:dz eg sa:6 arabic8
 Brezhoneg Breton:br:fr:1 15
 Bulgarski Bulgarian:bg:bg:5
-Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW GB2312 tw.EUC
+Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC
 Hrvatski Croatian:hr:hr:2
 Cymraeg Welsh:cy:cy:1 14 15
 Czech:cs:cz:2
 Dansk Danish:dk:da:1 15
 Nederlands Dutch:nl:be nl:1 15
-English American British:en:au ca gb ie nz us uk:1 15 cp850
+English American British:en:au ca gb ie nz us uk zw:1 15 cp850
 Esperanto:eo:eo:3
 Eesti Estonian:et:ee:4 6 13
 Suomi Finnish:fi:fi:1 15
@@ -271,11 +283,12 @@ Latvian:lv:lv:4 6 13
 Lithuanian:lt:lt:4 6 13
 Macedonian:mk:mk:1 15
 Maltese:mt:mt:3
-Norsk Norwegian:no:no:1 15
+Moldovan:mo:mo:2
+Norsk Norwegian:no no\@nynorsk:no:1 15
 Occitan:oc:es:1 15
 Polski Polish:pl:pl:2
 Rumanian:ro:ro:2
-Russki Russian:ru:ru su ua:5 koi8 koi8r koi8u cp1251
+Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866
 Serbski Serbian:sr:yu:5
 Slovak:sk:sk:2
 Slovene Slovenian:sl:si:2
@@ -283,10 +296,11 @@ Sqhip Albanian:sq:sq:1 15
 Svenska Swedish:sv:fi se:1 15
 Thai:th:th:11 tis620
 Turkish:tr:tr:9 turkish8
-Yiddish:::1 15
+Yiddish:yi::1 15
 EOF
 
 if ($^O eq 'os390') {
+    # These cause heartburn.  Broken locales?
     $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//;
     $locales =~ s/Thai:th:th:11 tis620\n//;
 }
@@ -326,6 +340,7 @@ sub decode_encodings {
 	    }
 	} else {
 	    push @enc, $_;
+   	    push @enc, "$_.UTF-8";
 	}
     }
     if ($^O eq 'os390') {
@@ -347,32 +362,61 @@ foreach (0..15) {
     trylocale("iso_latin_$_");
 }
 
-foreach my $locale (split(/\n/, $locales)) {
-    my ($locale_name, $language_codes, $country_codes, $encodings) =
-	split(/:/, $locale);
-    my @enc = decode_encodings($encodings);
-    foreach my $loc (split(/ /, $locale_name)) {
-	trylocale($loc);
-	foreach my $enc (@enc) {
-	    trylocale("$loc.$enc");
-	}
-	$loc = lc $loc;
-	foreach my $enc (@enc) {
-	    trylocale("$loc.$enc");
-	}
+# Sanitize the environment so that we can run the external 'locale'
+# program without the taint mode getting grumpy.
+
+# $ENV{PATH} is special in VMS.
+delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv};
+
+# Other subversive stuff.
+delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
+
+if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) {
+    while (<LOCALES>) {
+        chomp;
+	trylocale($_);
     }
-    foreach my $lang (split(/ /, $language_codes)) {
-	trylocale($lang);
-	foreach my $country (split(/ /, $country_codes)) {
-	    my $lc = "${lang}_${country}";
-	    trylocale($lc);
+    close(LOCALES);
+} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') {
+# The SYS$I18N_LOCALE logical name search list was not present on 
+# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions.
+    opendir(LOCALES, "SYS\$I18N_LOCALE:");
+    while ($_ = readdir(LOCALES)) {
+        chomp;
+        trylocale($_);
+    }
+    close(LOCALES);
+} else {
+
+    # This is going to be slow.
+
+    foreach my $locale (split(/\n/, $locales)) {
+	my ($locale_name, $language_codes, $country_codes, $encodings) =
+	    split(/:/, $locale);
+	my @enc = decode_encodings($encodings);
+	foreach my $loc (split(/ /, $locale_name)) {
+	    trylocale($loc);
 	    foreach my $enc (@enc) {
-		trylocale("$lc.$enc");
+		trylocale("$loc.$enc");
 	    }
-	    my $lC = "${lang}_\U${country}";
-	    trylocale($lC);
+	    $loc = lc $loc;
 	    foreach my $enc (@enc) {
-		trylocale("$lC.$enc");
+		trylocale("$loc.$enc");
+	    }
+	}
+	foreach my $lang (split(/ /, $language_codes)) {
+	    trylocale($lang);
+	    foreach my $country (split(/ /, $country_codes)) {
+		my $lc = "${lang}_${country}";
+		trylocale($lc);
+		foreach my $enc (@enc) {
+		    trylocale("$lc.$enc");
+		}
+		my $lC = "${lang}_\U${country}";
+		trylocale($lC);
+		foreach my $enc (@enc) {
+		    trylocale("$lC.$enc");
+		}
 	    }
 	}
     }
@@ -380,6 +424,8 @@ foreach my $locale (split(/\n/, $locales)) {
 
 setlocale(LC_ALL, "C");
 
+sub utf8locale { $_[0] =~ /utf-?8/i }
+
 @Locale = sort @Locale;
 
 debug "# Locales = @Locale\n";
@@ -392,8 +438,6 @@ my %Neoalpha;
 
 sub tryneoalpha {
     my ($Locale, $i, $test) = @_;
-    debug "# testing $i with locale '$Locale'\n"
-	unless $Testing{$i}{$Locale}++;
     unless ($test) {
 	$Problem{$i}{$Locale} = 1;
 	debug "# failed $i with locale '$Locale'\n";
@@ -405,7 +449,7 @@ sub tryneoalpha {
 foreach $Locale (@Locale) {
     debug "# Locale = $Locale\n";
     @Alnum_ = getalnum_();
-    debug "# \\w = @Alnum_\n";
+    debug "# w = ", join("",@Alnum_), "\n";
 
     unless (setlocale(LC_ALL, $Locale)) {
 	foreach (99..103) {
@@ -440,9 +484,9 @@ foreach $Locale (@Locale) {
 	delete $lower{$_};
     }
 
-    debug "# UPPER    = ", join(" ", sort keys %UPPER   ), "\n";
-    debug "# lower    = ", join(" ", sort keys %lower   ), "\n";
-    debug "# BoThCaSe = ", join(" ", sort keys %BoThCaSe), "\n";
+    debug "# UPPER    = ", join("", sort keys %UPPER   ), "\n";
+    debug "# lower    = ", join("", sort keys %lower   ), "\n";
+    debug "# BoThCaSe = ", join("", sort keys %BoThCaSe), "\n";
 
     # Find the alphabets that are not alphabets in the default locale.
 
@@ -458,7 +502,7 @@ foreach $Locale (@Locale) {
 
     @Neoalpha = sort @Neoalpha;
 
-    debug "# Neoalpha = @Neoalpha\n";
+    debug "# Neoalpha = ", join("",@Neoalpha), "\n";
 
     if (@Neoalpha == 0) {
 	# If we have no Neoalphas the remaining tests are no-ops.
@@ -470,7 +514,10 @@ foreach $Locale (@Locale) {
 
 	# Test \w.
     
-	{
+	if (utf8locale($Locale)) {
+	    # Until the polymorphic regexen arrive.
+	    debug "# skipping UTF-8 locale '$Locale'\n";
+	} else {
 	    my $word = join('', @Neoalpha);
 
 	    $word =~ /^(\w+)$/;
@@ -622,7 +669,9 @@ foreach $Locale (@Locale) {
 	tryneoalpha($Locale, 114, $f == $c);
     }
 
-    debug "# testing 115 with locale '$Locale'\n";
+    # Does taking lc separately differ from taking
+    # the lc "in-line"?  (This was the bug 19990704.002, change #3568.)
+    # The bug was in the caching of the 'o'-magic.
     {
 	use locale;
 
@@ -645,8 +694,13 @@ foreach $Locale (@Locale) {
 		    lcA($x, $z) == 0 && lcB($x, $z) == 0);
     }
 
-    debug "# testing 116 with locale '$Locale'\n";
-    {
+    # Does lc of an UPPER (if different from the UPPER) match
+    # case-insensitively the UPPER, and does the UPPER match
+    # case-insensitively the lc of the UPPER.  And vice versa.
+    if (utf8locale($Locale)) {
+        # Until the polymorphic regexen arrive.
+        debug "# skipping UTF-8 locale '$Locale'\n";
+    } else {
 	use locale;
 
 	my @f = ();
@@ -661,14 +715,16 @@ foreach $Locale (@Locale) {
 	    push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
 	}
 	tryneoalpha($Locale, 116, @f == 0);
-	print "# testing 116 failed for locale '$Locale' for characters @f\n"
-            if @f;
+        if (@f) {
+	    print "# failed 116 locale '$Locale' characters @f\n"
+        }
     }
+
 }
 
 # Recount the errors.
 
-foreach (99..116) {
+foreach (99..$last) {
     if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
 	if ($_ == 102) {
 	    print "# The failure of test 102 is not necessarily fatal.\n";
@@ -684,7 +740,7 @@ foreach (99..116) {
 
 my $didwarn = 0;
 
-foreach (99..116) {
+foreach (99..$last) {
     if ($Problem{$_}) {
 	my @f = sort keys %{ $Problem{$_} };
 	my $f = join(" ", @f);
@@ -709,26 +765,43 @@ EOW
     }
 }
 
-# Tell which locales ere okay.
+# Tell which locales were okay and which were not.
 
 if ($didwarn) {
-    my @s;
+    my (@s, @F);
     
     foreach my $l (@Locale) {
 	my $p = 0;
-	foreach my $t (102..102) {
+	foreach my $t (102..$last) {
 	    $p++ if $Problem{$t}{$l};
 	}
 	push @s, $l if $p == 0;
+      push @F, $l unless $p == 0;
     }
     
-    my $s = join(" ", @s);
-    $s =~ s/(.{50,60}) /$1\n#\t/g;
+    if (@s) {
+        my $s = join(" ", @s);
+        $s =~ s/(.{50,60}) /$1\n#\t/g;
+
+        warn
+    	    "# The following locales\n#\n",
+            "#\t", $s, "\n#\n",
+	    "# tested okay.\n#\n",
+    } else {
+        warn "# None of your locales were fully okay.\n";
+    }
 
-    warn
-	"# The following locales\n#\n",
-        "#\t", $s, "\n#\n",
-	"# tested okay.\n#\n",
+    if (@F) {
+        my $F = join(" ", @F);
+        $F =~ s/(.{50,60}) /$1\n#\t/g;
+
+        warn
+          "# The following locales\n#\n",
+            "#\t", $F, "\n#\n",
+          "# had problems.\n#\n",
+    } else {
+        warn "# None of your locales were broken.\n";
+    }
 }
 
 # eof
diff --git a/contrib/perl5/t/pragma/overload.t b/contrib/perl5/t/pragma/overload.t
index f9a9c59c87ed..a3007ef55b11 100755
--- a/contrib/perl5/t/pragma/overload.t
+++ b/contrib/perl5/t/pragma/overload.t
@@ -2,7 +2,7 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    unshift @INC, '../lib';
+    @INC = '../lib';
 }
 
 package Oscalar;
@@ -919,14 +919,69 @@ test $bar->[3], 13;		# 206
 my $aaa;
 { my $bbbb = 0; $aaa = bless \$bbbb, B }
 
-test !$aaa, 1;
+test !$aaa, 1;			# 207
 
 unless ($aaa) {
-  test 'ok', 'ok';
+  test 'ok', 'ok';		# 208
 } else {
-  test 'is not', 'ok';
+  test 'is not', 'ok';		# 208
 }
 
+# check that overload isn't done twice by join
+{ my $c = 0;
+  package Join;
+  use overload '""' => sub { $c++ };
+  my $x = join '', bless([]), 'pq', bless([]);
+  main::test $x, '0pq1';		# 209
+};
+
+# Test module-specific warning
+{
+    # check the Odd number of arguments for overload::constant warning
+    my $a = "" ;
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    $x = eval ' overload::constant "integer" ; ' ;
+    test($a eq "") ; # 210
+    use warnings 'overload' ;
+    $x = eval ' overload::constant "integer" ; ' ;
+    test($a =~ /^Odd number of arguments for overload::constant at/) ; # 211
+}
+
+{
+    # check the `$_[0]' is not an overloadable type warning
+    my $a = "" ;
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    $x = eval ' overload::constant "fred" => sub {} ; ' ;
+    test($a eq "") ; # 212
+    use warnings 'overload' ;
+    $x = eval ' overload::constant "fred" => sub {} ; ' ;
+    test($a =~ /^`fred' is not an overloadable type at/); # 213
+}
+
+{
+    # check the `$_[1]' is not a code reference warning
+    my $a = "" ;
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    $x = eval ' overload::constant "integer" => 1; ' ;
+    test($a eq "") ; # 214
+    use warnings 'overload' ;
+    $x = eval ' overload::constant "integer" => 1; ' ;
+    test($a =~ /^`1' is not a code reference at/); # 215
+}
+
+# make sure that we don't inifinitely recurse
+{
+  my $c = 0;
+  package Recurse;
+  use overload '""'    => sub { shift },
+               '0+'    => sub { shift },
+               'bool'  => sub { shift },
+               fallback => 1;
+  my $x = bless([]);
+  main::test("$x" =~ /Recurse=ARRAY/);		# 216
+  main::test($x);                               # 217
+  main::test($x+0 =~ /Recurse=ARRAY/);		# 218
+};
 
 # Last test is:
-sub last {208}
+sub last {218}
diff --git a/contrib/perl5/t/pragma/strict-vars b/contrib/perl5/t/pragma/strict-vars
index ae09742fab51..40b55572b808 100644
--- a/contrib/perl5/t/pragma/strict-vars
+++ b/contrib/perl5/t/pragma/strict-vars
@@ -55,7 +55,7 @@ Execution of - aborted due to compilation errors.
 
 # strict vars - error
 use strict 'vars' ;
-$fred ;
+<$fred> ;
 EXPECT
 Global symbol "$fred" requires explicit package name at - line 4.
 Execution of - aborted due to compilation errors.
@@ -151,8 +151,6 @@ $d = 1;$i = 1;$n = 1;
 $e = 1;$j = 1;$o = 1;
 $p = 0b12;
 --FILE-- 
-# known scalar leak
-BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; }
 use abc;
 EXPECT
 Global symbol "$f" requires explicit package name at abc.pm line 3.
@@ -171,8 +169,8 @@ Global symbol "$o" requires explicit package name at abc.pm line 7.
 Global symbol "$p" requires explicit package name at abc.pm line 8.
 Illegal binary digit '2' at abc.pm line 8, at end of line
 abc.pm has too many errors.
-Compilation failed in require at - line 3.
-BEGIN failed--compilation aborted at - line 3.
+Compilation failed in require at - line 1.
+BEGIN failed--compilation aborted at - line 1.
 ########
 
 # Check scope of pragma with eval
@@ -387,6 +385,8 @@ EXPECT
 # multiple our declarations in same scope, same package, warning
 use strict 'vars';
 use warnings;
+{ our $x = 1 }
+{ our $x = 0 }
 our $foo;
 {
     our $foo;
@@ -394,6 +394,17 @@ our $foo;
     our $foo;
 }
 EXPECT
-"our" variable $foo redeclared at - line 7.
+"our" variable $foo redeclared at - line 9.
 	(Did you mean "local" instead of "our"?)
-Name "Foo::foo" used only once: possible typo at - line 9.
+Name "Foo::foo" used only once: possible typo at - line 11.
+########
+
+# Make sure the strict vars failure still occurs
+# now that the `@i should be written as \@i' failure does not occur
+# 20000522 mjd@plover.com (MJD)
+use strict 'vars';
+no warnings;
+"@i_like_crackers";
+EXPECT
+Global symbol "@i_like_crackers" requires explicit package name at - line 7.
+Execution of - aborted due to compilation errors.
diff --git a/contrib/perl5/t/pragma/strict.t b/contrib/perl5/t/pragma/strict.t
index c4d64164e6ec..5b245d0ab45d 100755
--- a/contrib/perl5/t/pragma/strict.t
+++ b/contrib/perl5/t/pragma/strict.t
@@ -2,7 +2,7 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    unshift @INC, '../lib';
+    @INC = '../lib';
     $ENV{PERL5LIB} = '../lib';
 }
 
@@ -19,7 +19,7 @@ my @prgs = () ;
 
 foreach (sort glob("pragma/strict-*")) {
 
-    next if /(~|\.orig)$/;
+    next if /(~|\.orig|,v)$/;
 
     open F, "<$_" or die "Cannot open $_: $!\n" ;
     while (<F>) {
diff --git a/contrib/perl5/t/pragma/sub_lval.t b/contrib/perl5/t/pragma/sub_lval.t
index e96c329d8ef7..f19268b38487 100755
--- a/contrib/perl5/t/pragma/sub_lval.t
+++ b/contrib/perl5/t/pragma/sub_lval.t
@@ -1,12 +1,12 @@
-print "1..46\n";
+print "1..64\n";
 
 BEGIN {
     chdir 't' if -d 't';
-    unshift @INC, '../lib';
+    @INC = '../lib';
 }
 
-sub a : lvalue { my $a = 34; bless \$a }  # Return a temporary
-sub b : lvalue { shift }
+sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
+sub b : lvalue { ${\shift} }
 
 my $out = a(b());		# Check that temporaries are allowed.
 print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error.
@@ -34,9 +34,9 @@ print "ok 3\n";
 
 sub get_lex : lvalue { $in }
 sub get_st : lvalue { $blah }
-sub id : lvalue { shift }
+sub id : lvalue { ${\shift} }
 sub id1 : lvalue { $_[0] }
-sub inc : lvalue { ++$_[0] }
+sub inc : lvalue { ${\++$_[0]} }
 
 $in = 5;
 $blah = 3;
@@ -288,40 +288,41 @@ print "# '$_'.\nnot "
 print "ok 34\n";
 
 $x = '1234567';
-sub lv1t : lvalue { index $x, 2 }
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
+  sub lv1t : lvalue { index $x, 2 }
   lv1t = (2,3);
   1;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a temporary from lvalue subroutine/;
+  unless /Can\'t modify index in lvalue subroutine return/;
 print "ok 35\n";
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
-  (lv1t) = (2,3);
+  sub lv2t : lvalue { shift }
+  (lv2t) = (2,3);
   1;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a temporary from lvalue subroutine/;
+  unless /Can\'t modify shift in lvalue subroutine return/;
 print "ok 36\n";
 
 $xxx = 'xxx';
 sub xxx () { $xxx }  # Not lvalue
-sub lv1tmp : lvalue { xxx }			# is it a TEMP?
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
+  sub lv1tmp : lvalue { xxx }			# is it a TEMP?
   lv1tmp = (2,3);
   1;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a temporary from lvalue subroutine/;
+  unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/;
 print "ok 37\n";
 
 $_ = undef;
@@ -334,17 +335,17 @@ print "# '$_'.\nnot "
   unless /Can\'t return a temporary from lvalue subroutine/;
 print "ok 38\n";
 
-sub xxx () { 'xxx' } # Not lvalue
-sub lv1tmpr : lvalue { xxx }			# is it a TEMP?
+sub yyy () { 'yyy' } # Const, not lvalue
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
+  sub lv1tmpr : lvalue { yyy }			# is it read-only?
   lv1tmpr = (2,3);
   1;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a readonly value from lvalue subroutine/;
+  unless /Can\'t modify constant item in lvalue subroutine return/;
 print "ok 39\n";
 
 $_ = undef;
@@ -357,8 +358,6 @@ print "# '$_'.\nnot "
   unless /Can\'t return a readonly value from lvalue subroutine/;
 print "ok 40\n";
 
-=for disabled constructs
-
 sub lva : lvalue {@a}
 
 $_ = undef;
@@ -369,8 +368,7 @@ eval <<'EOE' or $_ = $@;
   1;
 EOE
 
-print "# '$_'.\nnot "
-  unless /Can\'t return an uninitialized value from lvalue subroutine/;
+print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 print "ok 41\n";
 
 $_ = undef;
@@ -397,10 +395,6 @@ EOE
 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 print "ok 43\n";
 
-=cut
-
-print "ok $_\n" for 41..43;
-
 sub lv1n : lvalue { $newvar }
 
 $_ = undef;
@@ -427,3 +421,122 @@ $a = \&lv1nn;
 $a->() = 8;
 print "# '$nnewvar'.\nnot " unless $nnewvar eq '8';
 print "ok 46\n";
+
+# This must happen at run time
+eval {
+    sub AUTOLOAD : lvalue { $newvar };
+};
+foobar() = 12;
+print "# '$newvar'.\nnot " unless $newvar eq "12";
+print "ok 47\n";
+
+# Testing DWIM of foo = bar;
+sub foo : lvalue {
+    $a;
+}
+$a = "not ok 48\n";
+foo = "ok 48\n";
+print $a;
+
+open bar, ">nothing" or die $!; 
+bar = *STDOUT;
+print bar "ok 49\n";
+unlink "nothing";
+
+{
+my %hash; my @array;
+sub alv : lvalue { $array[1] }
+sub alv2 : lvalue { $array[$_[0]] }
+sub hlv : lvalue { $hash{"foo"} }
+sub hlv2 : lvalue { $hash{$_[0]} }
+$array[1] = "not ok 51\n";
+alv() = "ok 50\n";
+print alv();
+
+alv2(20) = "ok 51\n";
+print $array[20];
+
+$hash{"foo"} = "not ok 52\n";
+hlv() = "ok 52\n";
+print $hash{foo};
+
+$hash{bar} = "not ok 53\n";
+hlv("bar") = "ok 53\n";
+print hlv("bar");
+
+sub array : lvalue  { @array  }
+sub array2 : lvalue { @array2 } # This is a global.
+sub hash : lvalue   { %hash   }
+sub hash2 : lvalue  { %hash2  } # So's this.
+@array2 = qw(foo bar);
+%hash2 = qw(foo bar);
+
+(array()) = qw(ok 54);
+print "not " unless "@array" eq "ok 54";
+print "ok 54\n";
+
+(array2()) = qw(ok 55);
+print "not " unless "@array2" eq "ok 55";
+print "ok 55\n";
+
+(hash()) = qw(ok 56);
+print "not " unless $hash{ok} == 56;
+print "ok 56\n";
+
+(hash2()) = qw(ok 57);
+print "not " unless $hash2{ok} == 57;
+print "ok 57\n";
+
+@array = qw(a b c d);
+sub aslice1 : lvalue { @array[0,2] };
+(aslice1()) = ("ok", "already");
+print "# @array\nnot " unless "@array" eq "ok b already d";
+print "ok 58\n";
+
+@array2 = qw(a B c d);
+sub aslice2 : lvalue { @array2[0,2] };
+(aslice2()) = ("ok", "already");
+print "not " unless "@array2" eq "ok B already d";
+print "ok 59\n";
+
+%hash = qw(a Alpha b Beta c Gamma);
+sub hslice : lvalue { @hash{"c", "b"} }
+(hslice()) = ("CISC", "BogoMIPS");
+print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS";
+print "ok 60\n";
+}
+
+$str = "Hello, world!";
+sub sstr : lvalue { substr($str, 1, 4) }
+sstr() = "i";
+print "not " unless $str eq "Hi, world!";
+print "ok 61\n";
+
+$str = "Made w/ JavaScript";
+sub veclv : lvalue { vec($str, 2, 32) }
+if (ord('A') != 193) {
+    veclv() = 0x5065726C;
+}
+else { # EBCDIC?
+    veclv() = 0xD7859993;
+}
+print "# $str\nnot " unless $str eq "Made w/ PerlScript";
+print "ok 62\n";
+
+sub position : lvalue { pos }
+@p = ();
+$_ = "fee fi fo fum";
+while (/f/g) {
+    push @p, position;
+    position() += 6;
+}
+print "# @p\nnot " unless "@p" eq "1 8";
+print "ok 63\n";
+
+# Bug 20001223.002: split thought that the list had only one element
+@ary = qw(4 5 6);
+sub lval1 : lvalue { $ary[0]; }
+sub lval2 : lvalue { $ary[1]; }
+(lval1(), lval2()) = split ' ', "1 2 3 4";
+print "not " unless join(':', @ary) eq "1:2:6";
+print "ok 64\n";
diff --git a/contrib/perl5/t/pragma/subs.t b/contrib/perl5/t/pragma/subs.t
index fe84f5ef76f6..7e48e201a87c 100755
--- a/contrib/perl5/t/pragma/subs.t
+++ b/contrib/perl5/t/pragma/subs.t
@@ -2,7 +2,7 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    unshift @INC, '../lib';
+    @INC = '../lib';
     $ENV{PERL5LIB} = '../lib';
 }
 
@@ -114,6 +114,30 @@ EXPECT
 3
 ########
 
+# override a built-in function, call after definition
+use subs qw( open ) ;
+sub open { print $_[0] + $_[1], "\n" }
+open 1,2 ;
+EXPECT
+3
+########
+
+# override a built-in function, call with ()
+use subs qw( open ) ;
+open (1,2) ;
+sub open { print $_[0] + $_[1], "\n" }
+EXPECT
+3
+########
+
+# override a built-in function, call with () after definition
+use subs qw( open ) ;
+sub open { print $_[0] + $_[1], "\n" }
+open (1,2) ;
+EXPECT
+3
+########
+
 --FILE-- abc
 Fred 1,2 ;
 1;
diff --git a/contrib/perl5/t/pragma/utf8.t b/contrib/perl5/t/pragma/utf8.t
index 0e55a67d6936..e0a321afe9c1 100755
--- a/contrib/perl5/t/pragma/utf8.t
+++ b/contrib/perl5/t/pragma/utf8.t
@@ -2,7 +2,7 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    unshift @INC, '../lib';
+    @INC = '../lib';
     $ENV{PERL5LIB} = '../lib';
     if ( ord("\t") != 9 ) { # skip on ebcdic platforms
         print "1..0 # Skip utf8 tests on ebcdic platform.\n";
@@ -10,7 +10,7 @@ BEGIN {
     }
 }
 
-print "1..60\n";
+print "1..90\n";
 
 my $test = 1;
 
@@ -20,234 +20,443 @@ sub ok {
     print "ok $test\n";
 }
 
+sub nok {
+    my ($got,$expect) = @_;
+    print "# expected not [$expect], got [$got]\nnot " if $got eq $expect;
+    print "ok $test\n";
+}
+
+sub ok_bytes {
+    use bytes;
+    my ($got,$expect) = @_;
+    print "# expected [$expect], got [$got]\nnot " if $got ne $expect;
+    print "ok $test\n";
+}
+
+sub nok_bytes {
+    use bytes;
+    my ($got,$expect) = @_;
+    print "# expected not [$expect], got [$got]\nnot " if $got eq $expect;
+    print "ok $test\n";
+}
+
 {
     use utf8;
     $_ = ">\x{263A}<"; 
     s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg; 
     ok $_, '>&#9786;<';
-    $test++;
+    $test++;				# 1
 
     $_ = ">\x{263A}<"; 
     my $rx = "\x{80}-\x{10ffff}";
     s/([$rx])/"&#".ord($1).";"/eg; 
     ok $_, '>&#9786;<';
-    $test++;
+    $test++;				# 2
 
     $_ = ">\x{263A}<"; 
     my $rx = "\\x{80}-\\x{10ffff}";
     s/([$rx])/"&#".ord($1).";"/eg; 
     ok $_, '>&#9786;<';
-    $test++;
+    $test++;				# 3
 
     $_ = "alpha,numeric"; 
     m/([[:alpha:]]+)/; 
     ok $1, 'alpha';
-    $test++;
+    $test++;				# 4
 
     $_ = "alphaNUMERICstring";
     m/([[:^lower:]]+)/; 
     ok $1, 'NUMERIC';
-    $test++;
+    $test++;				# 5
 
     $_ = "alphaNUMERICstring";
     m/(\p{Ll}+)/; 
     ok $1, 'alpha';
-    $test++;
+    $test++;				# 6
 
     $_ = "alphaNUMERICstring"; 
     m/(\p{Lu}+)/; 
     ok $1, 'NUMERIC';
-    $test++;
+    $test++;				# 7
 
     $_ = "alpha,numeric"; 
     m/([\p{IsAlpha}]+)/; 
     ok $1, 'alpha';
-    $test++;
+    $test++;				# 8
 
     $_ = "alphaNUMERICstring";
     m/([^\p{IsLower}]+)/; 
     ok $1, 'NUMERIC';
-    $test++;
+    $test++;				# 9
 
     $_ = "alpha123numeric456"; 
     m/([\p{IsDigit}]+)/; 
     ok $1, '123';
-    $test++;
+    $test++;				# 10
 
     $_ = "alpha123numeric456"; 
     m/([^\p{IsDigit}]+)/; 
     ok $1, 'alpha';
-    $test++;
+    $test++;				# 11
 
     $_ = ",123alpha,456numeric"; 
     m/([\p{IsAlnum}]+)/; 
     ok $1, '123alpha';
-    $test++;
+    $test++;				# 12
 }
+
 {
     use utf8;
 
     $_ = "\x{263A}>\x{263A}\x{263A}"; 
 
     ok length, 4;
-    $test++;
+    $test++;				# 13
 
     ok length((m/>(.)/)[0]), 1;
-    $test++;
+    $test++;				# 14
 
     ok length($&), 2;
-    $test++;
+    $test++;				# 15
 
     ok length($'), 1;
-    $test++;
+    $test++;				# 16
 
     ok length($`), 1;
-    $test++;
+    $test++;				# 17
 
     ok length($1), 1;
-    $test++;
+    $test++;				# 18
 
     ok length($tmp=$&), 2;
-    $test++;
+    $test++;				# 19
 
     ok length($tmp=$'), 1;
-    $test++;
+    $test++;				# 20
 
     ok length($tmp=$`), 1;
-    $test++;
+    $test++;				# 21
 
     ok length($tmp=$1), 1;
-    $test++;
+    $test++;				# 22
 
-    ok $&, pack("C*", ord(">"), 0342, 0230, 0272);
-    $test++;
+    {
+	use bytes;
 
-    ok $', pack("C*", 0342, 0230, 0272);
-    $test++;
+	my $tmp = $&;
+	ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272);
+	$test++;				# 23
 
-    ok $`, pack("C*", 0342, 0230, 0272);
-    $test++;
+	$tmp = $';
+	ok $tmp, pack("C*", 0342, 0230, 0272);
+	$test++;				# 24
 
-    ok $1, pack("C*", 0342, 0230, 0272);
-    $test++;
+	$tmp = $`;
+	ok $tmp, pack("C*", 0342, 0230, 0272);
+	$test++;				# 25
+
+	$tmp = $1;
+	ok $tmp, pack("C*", 0342, 0230, 0272);
+	$test++;				# 26
+    }
+
+    ok_bytes $&, pack("C*", ord(">"), 0342, 0230, 0272);
+    $test++;				# 27
+
+    ok_bytes $', pack("C*", 0342, 0230, 0272);
+    $test++;				# 28
+
+    ok_bytes $`, pack("C*", 0342, 0230, 0272);
+    $test++;				# 29
+
+    ok_bytes $1, pack("C*", 0342, 0230, 0272);
+    $test++;				# 30
 
     {
 	use bytes;
 	no utf8;
 
 	ok length, 10;
-	$test++;
+	$test++;				# 31
 
     	ok length((m/>(.)/)[0]), 1;
-    	$test++;
+    	$test++;				# 32
 
     	ok length($&), 2;
-    	$test++;
+    	$test++;				# 33
 
     	ok length($'), 5;
-    	$test++;
+    	$test++;				# 34
 
     	ok length($`), 3;
-    	$test++;
+    	$test++;				# 35
 
     	ok length($1), 1;
-    	$test++;
+    	$test++;				# 36
 
 	ok $&, pack("C*", ord(">"), 0342);
-	$test++;
+	$test++;				# 37
 
 	ok $', pack("C*", 0230, 0272, 0342, 0230, 0272);
-	$test++;
+	$test++;				# 38
 
 	ok $`, pack("C*", 0342, 0230, 0272);
-	$test++;
+	$test++;				# 39
 
 	ok $1, pack("C*", 0342);
-	$test++;
-
+	$test++;				# 40
     }
 
-
     {
 	no utf8;
 	$_="\342\230\272>\342\230\272\342\230\272";
     }
 
     ok length, 10;
-    $test++;
+    $test++;				# 41
 
     ok length((m/>(.)/)[0]), 1;
-    $test++;
+    $test++;				# 42
 
     ok length($&), 2;
-    $test++;
+    $test++;				# 43
 
     ok length($'), 1;
-    $test++;
+    $test++;				# 44
 
     ok length($`), 1;
-    $test++;
+    $test++;				# 45
 
     ok length($1), 1;
-    $test++;
+    $test++;				# 46
 
     ok length($tmp=$&), 2;
-    $test++;
+    $test++;				# 47
 
     ok length($tmp=$'), 1;
-    $test++;
+    $test++;				# 48
 
     ok length($tmp=$`), 1;
-    $test++;
+    $test++;				# 49
 
     ok length($tmp=$1), 1;
-    $test++;
+    $test++;				# 50
 
-    ok $&, pack("C*", ord(">"), 0342, 0230, 0272);
-    $test++;
+    {
+	use bytes;
 
-    ok $', pack("C*", 0342, 0230, 0272);
-    $test++;
+        my $tmp = $&;
+	ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272);
+	$test++;				# 51
 
-    ok $`, pack("C*", 0342, 0230, 0272);
-    $test++;
+        $tmp = $';
+	ok $tmp, pack("C*", 0342, 0230, 0272);
+	$test++;				# 52
 
-    ok $1, pack("C*", 0342, 0230, 0272);
-    $test++;
+        $tmp = $`;
+	ok $tmp, pack("C*", 0342, 0230, 0272);
+	$test++;				# 53
+
+        $tmp = $1;
+	ok $tmp, pack("C*", 0342, 0230, 0272);
+	$test++;				# 54
+    }
 
     {
 	use bytes;
 	no utf8;
 
 	ok length, 10;
-	$test++;
+	$test++;				# 55
 
     	ok length((m/>(.)/)[0]), 1;
-    	$test++;
+    	$test++;				# 56
 
     	ok length($&), 2;
-    	$test++;
+    	$test++;				# 57
 
     	ok length($'), 5;
-    	$test++;
+    	$test++;				# 58
 
     	ok length($`), 3;
-    	$test++;
+    	$test++;				# 59
 
     	ok length($1), 1;
-    	$test++;
+    	$test++;				# 60
 
 	ok $&, pack("C*", ord(">"), 0342);
-	$test++;
+	$test++;				# 61
 
 	ok $', pack("C*", 0230, 0272, 0342, 0230, 0272);
-	$test++;
+	$test++;				# 62
 
 	ok $`, pack("C*", 0342, 0230, 0272);
-	$test++;
+	$test++;				# 63
 
 	ok $1, pack("C*", 0342);
+	$test++;				# 64
+    }
+
+    ok "\x{ab}" =~ /^\x{ab}$/, 1;
+    $test++;					# 65
+}
+
+{
+    use utf8;
+    ok join(" ",unpack("C*",chr(128).chr(255))), "128 255";
+    $test++;
+}
+
+{
+    use utf8;
+    my @a = map ord, split(//, join("", map chr, (1234, 123, 2345)));
+    ok "@a", "1234 123 2345";
+    $test++;                # 67
+}
+
+{
+    use utf8;
+    my $x = chr(123);
+    my @a = map ord, split(/$x/, join("", map chr, (1234, 123, 2345)));
+    ok "@a", "1234 2345";
+    $test++;                # 68
+}
+
+{
+    # bug id 20001009.001
+
+    my ($a, $b);
+
+    { use bytes; $a = "\xc3\xa4" }
+    { use utf8;  $b = "\xe4"     } # \xXX must not produce UTF-8
+
+    print "not " if $a eq $b;
+    print "ok $test\n"; $test++;
+
+    { use utf8; print "not " if $a eq $b; }
+    print "ok $test\n"; $test++;
+}
+
+{
+    # bug id 20001008.001
+
+    my @x = ("stra\337e 138","stra\337e 138");
+    for (@x) {
+	s/(\d+)\s*([\w\-]+)/$1 . uc $2/e;
+	my($latin) = /^(.+)(?:\s+\d)/;
+	print $latin eq "stra\337e" ? "ok $test\n" :
+	    "#latin[$latin]\nnot ok $test\n";
+	$test++;
+	$latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a
+	use utf8;
+	$latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a
+    }
+}
+
+{
+    # bug id 20000427.003 
+
+    use utf8;
+    use warnings;
+    use strict;
+
+    my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}";
+
+    my @charlist = split //, $sushi;
+    my $r = '';
+    foreach my $ch (@charlist) {
+	$r = $r . " " . sprintf "U+%04X", ord($ch);
+    }
+
+    print "not " unless $r eq " U+B36C U+5A8C U+FF5B U+5079 U+505B";
+    print "ok $test\n";
+    $test++;
+}
+
+{
+    # bug id 20000426.003
+
+    use utf8;
+
+    my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20";
+
+    my ($a, $b, $c) = split(/\x40/, $s);
+    print "not "
+	unless $a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a;
+    print "ok $test\n";
+    $test++;
+
+    my ($a, $b) = split(/\x{100}/, $s);
+    print "not " unless $a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20";
+    print "ok $test\n";
+    $test++;
+
+    my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s);
+    print "not " unless $a eq "\x20\x40" && $b eq "\x40\x20";
+    print "ok $test\n";
+    $test++;
+
+    my ($a, $b) = split(/\x40\x{80}/, $s);
+    print "not " unless $a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20";
+    print "ok $test\n";
+    $test++;
+
+    my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s);
+    print "not " unless $a eq "\x20" && $b eq "\x{100}" && $c eq "\x20";
+    print "ok $test\n";
+    $test++;
+}
+
+{
+    # bug id 20000730.004
+
+    use utf8;
+
+    my $smiley = "\x{263a}";
+
+    for my $s ("\x{263a}",                     #  1
+	       $smiley,                        #  2
+		
+	       "" . $smiley,                   #  3
+	       "" . "\x{263a}",                #  4
+
+	       $smiley    . "",                #  5
+	       "\x{263a}" . "",                #  6
+	       ) {
+	my $length_chars = length($s);
+	my $length_bytes;
+	{ use bytes; $length_bytes = length($s) }
+	my @regex_chars = $s =~ m/(.)/g;
+	my $regex_chars = @regex_chars;
+	my @split_chars = split //, $s;
+	my $split_chars = @split_chars;
+	print "not "
+	    unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq
+		   "1/1/1/3";
+	print "ok $test\n";
 	$test++;
+    }
 
+    for my $s ("\x{263a}" . "\x{263a}",        #  7
+	       $smiley    . $smiley,           #  8
+
+	       "\x{263a}\x{263a}",             #  9
+	       "$smiley$smiley",               # 10
+	       
+	       "\x{263a}" x 2,                 # 11
+	       $smiley    x 2,                 # 12
+	       ) {
+	my $length_chars = length($s);
+	my $length_bytes;
+	{ use bytes; $length_bytes = length($s) }
+	my @regex_chars = $s =~ m/(.)/g;
+	my $regex_chars = @regex_chars;
+	my @split_chars = split //, $s;
+	my $split_chars = @split_chars;
+	print "not "
+	    unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq
+		   "2/2/2/6";
+	print "ok $test\n";
+	$test++;
     }
 }
diff --git a/contrib/perl5/t/pragma/warn/2use b/contrib/perl5/t/pragma/warn/2use
index 60a60c313cb0..b489d62e1991 100644
--- a/contrib/perl5/t/pragma/warn/2use
+++ b/contrib/perl5/t/pragma/warn/2use
@@ -120,175 +120,223 @@ Use of uninitialized value in scalar chop at - line 3.
 ########
 
 # Check scope of pragma with eval
-no warnings ;
-eval {
+use warnings;
+{
+    no warnings ;
+    eval {
+        my $b ; chop $b ;
+    }; print STDERR $@ ;
     my $b ; chop $b ;
-}; print STDERR $@ ;
-my $b ; chop $b ;
+}
 EXPECT
 
 ########
 
 # Check scope of pragma with eval
-no warnings ;
-eval {
-    use warnings 'uninitialized' ;
+use warnings;
+{
+    no warnings ;
+    eval {
+        use warnings 'uninitialized' ;
+        my $b ; chop $b ;
+    }; print STDERR $@ ;
     my $b ; chop $b ;
-}; print STDERR $@ ;
-my $b ; chop $b ;
+}
 EXPECT
-Use of uninitialized value in scalar chop at - line 6.
+Use of uninitialized value in scalar chop at - line 8.
 ########
 
 # Check scope of pragma with eval
-use warnings 'uninitialized' ;
-eval {
+no warnings;
+{
+    use warnings 'uninitialized' ;
+    eval {
+        my $b ; chop $b ;
+    }; print STDERR $@ ;
     my $b ; chop $b ;
-}; print STDERR $@ ;
-my $b ; chop $b ;
+}
 EXPECT
-Use of uninitialized value in scalar chop at - line 5.
 Use of uninitialized value in scalar chop at - line 7.
+Use of uninitialized value in scalar chop at - line 9.
 ########
 
 # Check scope of pragma with eval
-use warnings 'uninitialized' ;
-eval {
-    no warnings ;
+no warnings;
+{
+    use warnings 'uninitialized' ;
+    eval {
+        no warnings ;
+        my $b ; chop $b ;
+    }; print STDERR $@ ;
     my $b ; chop $b ;
-}; print STDERR $@ ;
-my $b ; chop $b ;
+}
 EXPECT
-Use of uninitialized value in scalar chop at - line 8.
+Use of uninitialized value in scalar chop at - line 10.
 ########
 
 # Check scope of pragma with eval
-no warnings ;
-eval {
+use warnings;
+{
+    no warnings ;
+    eval {
+        1 if $a EQ $b ;
+    }; print STDERR $@ ;
     1 if $a EQ $b ;
-}; print STDERR $@ ;
-1 if $a EQ $b ;
+}
 EXPECT
 
 ########
 
 # Check scope of pragma with eval
-no warnings ;
-eval {
-    use warnings 'deprecated' ;
+use warnings;
+{
+    no warnings ;
+    eval {
+        use warnings 'deprecated' ;
+        1 if $a EQ $b ;
+    }; print STDERR $@ ;
     1 if $a EQ $b ;
-}; print STDERR $@ ;
-1 if $a EQ $b ;
+}
 EXPECT
-Use of EQ is deprecated at - line 6.
+Use of EQ is deprecated at - line 8.
 ########
 
 # Check scope of pragma with eval
-use warnings 'deprecated' ;
-eval {
+no warnings;
+{
+    use warnings 'deprecated' ;
+    eval {
+        1 if $a EQ $b ;
+    }; print STDERR $@ ;
     1 if $a EQ $b ;
-}; print STDERR $@ ;
-1 if $a EQ $b ;
+}
 EXPECT
-Use of EQ is deprecated at - line 5.
 Use of EQ is deprecated at - line 7.
+Use of EQ is deprecated at - line 9.
 ########
 
 # Check scope of pragma with eval
-use warnings 'deprecated' ;
-eval {
-    no warnings ;
+no warnings;
+{
+    use warnings 'deprecated' ;
+    eval {
+        no warnings ;
+        1 if $a EQ $b ;
+    }; print STDERR $@ ;
     1 if $a EQ $b ;
-}; print STDERR $@ ;
-1 if $a EQ $b ;
+}
 EXPECT
-Use of EQ is deprecated at - line 8.
+Use of EQ is deprecated at - line 10.
 ########
 
 # Check scope of pragma with eval
-no warnings ;
-eval '
+use warnings;
+{
+    no warnings ;
+    eval '
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
     my $b ; chop $b ;
-'; print STDERR $@ ;
-my $b ; chop $b ;
+}
 EXPECT
 
 ########
 
 # Check scope of pragma with eval
-no warnings ;
-eval q[ 
-    use warnings 'uninitialized' ;
+use warnings;
+{
+    no warnings ;
+    eval q[ 
+        use warnings 'uninitialized' ;
+        my $b ; chop $b ;
+    ]; print STDERR $@;
     my $b ; chop $b ;
-]; print STDERR $@;
-my $b ; chop $b ;
+}
 EXPECT
 Use of uninitialized value in scalar chop at (eval 1) line 3.
 ########
 
 # Check scope of pragma with eval
-use warnings 'uninitialized' ;
-eval '
+no warnings;
+{
+    use warnings 'uninitialized' ;
+    eval '
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
     my $b ; chop $b ;
-'; print STDERR $@ ;
-my $b ; chop $b ;
+}
 EXPECT
 Use of uninitialized value in scalar chop at (eval 1) line 2.
-Use of uninitialized value in scalar chop at - line 7.
+Use of uninitialized value in scalar chop at - line 9.
 ########
 
 # Check scope of pragma with eval
-use warnings 'uninitialized' ;
-eval '
-    no warnings ;
+no warnings;
+{
+    use warnings 'uninitialized' ;
+    eval '
+        no warnings ;
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
     my $b ; chop $b ;
-'; print STDERR $@ ;
-my $b ; chop $b ;
+}
 EXPECT
-Use of uninitialized value in scalar chop at - line 8.
+Use of uninitialized value in scalar chop at - line 10.
 ########
 
 # Check scope of pragma with eval
-no warnings ;
-eval '
+use warnings;
+{
+    no warnings ;
+    eval '
+        1 if $a EQ $b ;
+    '; print STDERR $@ ;
     1 if $a EQ $b ;
-'; print STDERR $@ ;
-1 if $a EQ $b ;
+}
 EXPECT
 
 ########
 
 # Check scope of pragma with eval
-no warnings ;
-eval q[ 
-    use warnings 'deprecated' ;
+use warnings;
+{
+    no warnings ;
+    eval q[ 
+        use warnings 'deprecated' ;
+        1 if $a EQ $b ;
+    ]; print STDERR $@;
     1 if $a EQ $b ;
-]; print STDERR $@;
-1 if $a EQ $b ;
+}
 EXPECT
 Use of EQ is deprecated at (eval 1) line 3.
 ########
 
 # Check scope of pragma with eval
-use warnings 'deprecated' ;
-eval '
+no warnings;
+{
+    use warnings 'deprecated' ;
+    eval '
+        1 if $a EQ $b ;
+    '; print STDERR $@;
     1 if $a EQ $b ;
-'; print STDERR $@;
-1 if $a EQ $b ;
+}
 EXPECT
-Use of EQ is deprecated at - line 7.
+Use of EQ is deprecated at - line 9.
 Use of EQ is deprecated at (eval 1) line 2.
 ########
 
 # Check scope of pragma with eval
-use warnings 'deprecated' ;
-eval '
-    no warnings ;
+no warnings;
+{
+    use warnings 'deprecated' ;
+    eval '
+        no warnings ;
+        1 if $a EQ $b ;
+    '; print STDERR $@;
     1 if $a EQ $b ;
-'; print STDERR $@;
-1 if $a EQ $b ;
+}
 EXPECT
-Use of EQ is deprecated at - line 8.
+Use of EQ is deprecated at - line 10.
 ########
 
 # Check the additive nature of the pragma
diff --git a/contrib/perl5/t/pragma/warn/3both b/contrib/perl5/t/pragma/warn/3both
index 132b99b80fba..335e1b26b7a5 100644
--- a/contrib/perl5/t/pragma/warn/3both
+++ b/contrib/perl5/t/pragma/warn/3both
@@ -195,3 +195,72 @@ my $b ;
 chop $b ;
 EXPECT
 Use of uninitialized value in scalar chop at - line 7.
+########
+
+# Check scope of pragma with eval
+BEGIN {  $^W = 1 }
+{
+    no warnings ;
+    eval '
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
+    my $b ; chop $b ;
+}
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+BEGIN {  $^W = 1 }
+use warnings;
+{
+    no warnings ;
+    eval q[ 
+        use warnings 'uninitialized' ;
+        my $b ; chop $b ;
+    ]; print STDERR $@;
+    my $b ; chop $b ;
+}
+EXPECT
+Use of uninitialized value in scalar chop at (eval 1) line 3.
+########
+
+# Check scope of pragma with eval
+BEGIN {  $^W = 0 }
+{
+    use warnings 'uninitialized' ;
+    eval '
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
+    my $b ; chop $b ;
+}
+EXPECT
+Use of uninitialized value in scalar chop at (eval 1) line 2.
+Use of uninitialized value in scalar chop at - line 9.
+########
+
+# Check scope of pragma with eval
+BEGIN {  $^W = 0 }
+{
+    use warnings 'uninitialized' ;
+    eval '
+        no warnings ;
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
+    my $b ; chop $b ;
+}
+EXPECT
+Use of uninitialized value in scalar chop at - line 10.
+########
+
+# Check scope of pragma with eval
+BEGIN {  $^W = 1 }
+{
+    no warnings ;
+    eval '
+        1 if $a EQ $b ;
+    '; print STDERR $@ ;
+    1 if $a EQ $b ;
+}
+EXPECT
+
diff --git a/contrib/perl5/t/pragma/warn/4lint b/contrib/perl5/t/pragma/warn/4lint
index db54f31c7b4c..b2fa75fbbd94 100644
--- a/contrib/perl5/t/pragma/warn/4lint
+++ b/contrib/perl5/t/pragma/warn/4lint
@@ -9,14 +9,14 @@ $a = 1 if $a EQ $b ;
 close STDIN ; print STDIN "abc" ;
 EXPECT
 Use of EQ is deprecated at - line 5.
-print() on closed filehandle main::STDIN at - line 6.
+print() on closed filehandle STDIN at - line 6.
 ########
 -W
 # lint: check runtime $^W is zapped
 $^W = 0 ;
 close STDIN ; print STDIN "abc" ;
 EXPECT
-print() on closed filehandle main::STDIN at - line 4.
+print() on closed filehandle STDIN at - line 4.
 ########
 -W
 # lint: check runtime $^W is zapped
@@ -25,7 +25,7 @@ print() on closed filehandle main::STDIN at - line 4.
   close STDIN ; print STDIN "abc" ;
 }
 EXPECT
-print() on closed filehandle main::STDIN at - line 5.
+print() on closed filehandle STDIN at - line 5.
 ########
 -W
 # lint: check "no warnings" is zapped
@@ -35,7 +35,7 @@ $a = 1 if $a EQ $b ;
 close STDIN ; print STDIN "abc" ;
 EXPECT
 Use of EQ is deprecated at - line 5.
-print() on closed filehandle main::STDIN at - line 6.
+print() on closed filehandle STDIN at - line 6.
 ########
 -W
 # lint: check "no warnings" is zapped
@@ -44,7 +44,7 @@ print() on closed filehandle main::STDIN at - line 6.
   close STDIN ; print STDIN "abc" ;
 }
 EXPECT
-print() on closed filehandle main::STDIN at - line 5.
+print() on closed filehandle STDIN at - line 5.
 ########
 -Ww
 # lint: check combination of -w and -W
@@ -53,7 +53,7 @@ print() on closed filehandle main::STDIN at - line 5.
   close STDIN ; print STDIN "abc" ;
 }
 EXPECT
-print() on closed filehandle main::STDIN at - line 5.
+print() on closed filehandle STDIN at - line 5.
 ########
 -W
 --FILE-- abc.pm
@@ -110,3 +110,107 @@ my $a ; chop $a ;
 EXPECT
 Use of EQ is deprecated at ./abc line 3.
 Use of uninitialized value in scalar chop at - line 3.
+########
+-W
+# Check scope of pragma with eval
+{
+    no warnings ;
+    eval '
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
+    my $b ; chop $b ;
+}
+EXPECT
+Use of uninitialized value in scalar chop at (eval 1) line 2.
+Use of uninitialized value in scalar chop at - line 8.
+########
+-W
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval q[ 
+        use warnings 'uninitialized' ;
+        my $b ; chop $b ;
+    ]; print STDERR $@;
+    my $b ; chop $b ;
+}
+EXPECT
+Use of uninitialized value in scalar chop at (eval 1) line 3.
+Use of uninitialized value in scalar chop at - line 10.
+########
+-W
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'uninitialized' ;
+    eval '
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
+    my $b ; chop $b ;
+}
+EXPECT
+Use of uninitialized value in scalar chop at (eval 1) line 2.
+Use of uninitialized value in scalar chop at - line 9.
+########
+-W
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'uninitialized' ;
+    eval '
+        no warnings ;
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
+    my $b ; chop $b ;
+}
+EXPECT
+Use of uninitialized value in scalar chop at (eval 1) line 3.
+Use of uninitialized value in scalar chop at - line 10.
+########
+-W
+# Check scope of pragma with eval
+use warnings;
+{
+    my $a = "1"; my $b = "2";
+    no warnings ;
+    eval q[ 
+        use warnings 'deprecated' ;
+        1 if $a EQ $b ;
+    ]; print STDERR $@;
+    1 if $a EQ $b ;
+}
+EXPECT
+Use of EQ is deprecated at - line 11.
+Use of EQ is deprecated at (eval 1) line 3.
+########
+-W
+# Check scope of pragma with eval
+no warnings;
+{
+    my $a = "1"; my $b = "2";
+    use warnings 'deprecated' ;
+    eval '
+        1 if $a EQ $b ;
+    '; print STDERR $@;
+    1 if $a EQ $b ;
+}
+EXPECT
+Use of EQ is deprecated at - line 10.
+Use of EQ is deprecated at (eval 1) line 2.
+########
+-W
+# Check scope of pragma with eval
+no warnings;
+{
+    my $a = "1"; my $b = "2";
+    use warnings 'deprecated' ;
+    eval '
+        no warnings ;
+        1 if $a EQ $b ;
+    '; print STDERR $@;
+    1 if $a EQ $b ;
+}
+EXPECT
+Use of EQ is deprecated at - line 11.
+Use of EQ is deprecated at (eval 1) line 3.
diff --git a/contrib/perl5/t/pragma/warn/5nolint b/contrib/perl5/t/pragma/warn/5nolint
index 994190a85593..2459968003d7 100644
--- a/contrib/perl5/t/pragma/warn/5nolint
+++ b/contrib/perl5/t/pragma/warn/5nolint
@@ -94,3 +94,111 @@ $^W = 1 ;
 require "./abc";
 my $a ; chop $a ;
 EXPECT
+########
+-X
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval '
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
+    my $b ; chop $b ;
+}
+EXPECT
+
+########
+-X
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval q[ 
+        use warnings 'uninitialized' ;
+        my $b ; chop $b ;
+    ]; print STDERR $@;
+    my $b ; chop $b ;
+}
+EXPECT
+
+########
+-X
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'uninitialized' ;
+    eval '
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
+    my $b ; chop $b ;
+}
+EXPECT
+
+########
+-X
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'uninitialized' ;
+    eval '
+        no warnings ;
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
+    my $b ; chop $b ;
+}
+EXPECT
+
+########
+-X
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval '
+        1 if $a EQ $b ;
+    '; print STDERR $@ ;
+    1 if $a EQ $b ;
+}
+EXPECT
+
+########
+-X
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval q[ 
+        use warnings 'deprecated' ;
+        1 if $a EQ $b ;
+    ]; print STDERR $@;
+    1 if $a EQ $b ;
+}
+EXPECT
+
+########
+-X
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'deprecated' ;
+    eval '
+        1 if $a EQ $b ;
+    '; print STDERR $@;
+    1 if $a EQ $b ;
+}
+EXPECT
+
+########
+-X
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'deprecated' ;
+    eval '
+        no warnings ;
+        1 if $a EQ $b ;
+    '; print STDERR $@;
+    1 if $a EQ $b ;
+}
+EXPECT
+
diff --git a/contrib/perl5/t/pragma/warn/6default b/contrib/perl5/t/pragma/warn/6default
index dd3d1825f442..a8aafeeb2256 100644
--- a/contrib/perl5/t/pragma/warn/6default
+++ b/contrib/perl5/t/pragma/warn/6default
@@ -51,3 +51,71 @@ EXPECT
 Integer overflow in binary number at - line 3.
 Illegal binary digit '2' ignored at - line 3.
 Binary number > 0b11111111111111111111111111111111 non-portable at - line 3.
+########
+
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval '
+	my $a = oct "0xfffffffffffffffffg" ;
+    '; print STDERR $@ ;
+    my $a = oct "0xfffffffffffffffffg" ;
+}
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval q[ 
+        use warnings ;
+	my $a = oct "0xfffffffffffffffffg" ;
+    ]; print STDERR $@;
+    my $a = oct "0xfffffffffffffffffg" ;
+}
+EXPECT
+Integer overflow in hexadecimal number at (eval 1) line 3.
+Illegal hexadecimal digit 'g' ignored at (eval 1) line 3.
+Hexadecimal number > 0xffffffff non-portable at (eval 1) line 3.
+########
+
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings ;
+    eval '
+	my $a = oct "0xfffffffffffffffffg" ;
+    '; print STDERR $@ ;
+}
+EXPECT
+Integer overflow in hexadecimal number at (eval 1) line 2.
+Illegal hexadecimal digit 'g' ignored at (eval 1) line 2.
+Hexadecimal number > 0xffffffff non-portable at (eval 1) line 2.
+########
+
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings;
+    eval '
+        no warnings ;
+	my $a = oct "0xfffffffffffffffffg" ;
+    '; print STDERR $@ ;
+}
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'deprecated' ;
+    eval '
+	my $a = oct "0xfffffffffffffffffg" ;
+    '; print STDERR $@;
+}
+EXPECT
+
diff --git a/contrib/perl5/t/pragma/warn/7fatal b/contrib/perl5/t/pragma/warn/7fatal
index 943bb06fb34d..ed585c2fedab 100644
--- a/contrib/perl5/t/pragma/warn/7fatal
+++ b/contrib/perl5/t/pragma/warn/7fatal
@@ -14,6 +14,18 @@ EXPECT
 Use of EQ is deprecated at - line 8.
 ########
 
+# Check compile time warning
+use warnings FATAL => 'all' ;
+{
+    no warnings ;
+    1 if $a EQ $b ;
+}
+1 if $a EQ $b ; 
+print STDERR "The End.\n" ;
+EXPECT
+Use of EQ is deprecated at - line 8.
+########
+
 # Check runtime scope of pragma
 use warnings FATAL => 'uninitialized' ;
 {
@@ -27,6 +39,18 @@ Use of uninitialized value in scalar chop at - line 8.
 ########
 
 # Check runtime scope of pragma
+use warnings FATAL => 'all' ;
+{
+    no warnings ;
+    my $b ; chop $b ;
+}
+my $b ; chop $b ;
+print STDERR "The End.\n" ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 8.
+########
+
+# Check runtime scope of pragma
 no warnings ;
 {
     use warnings FATAL => 'uninitialized' ;
@@ -38,6 +62,18 @@ EXPECT
 Use of uninitialized value in scalar chop at - line 6.
 ########
 
+# Check runtime scope of pragma
+no warnings ;
+{
+    use warnings FATAL => 'all' ;
+    $a = sub { my $b ; chop $b ; }
+}
+&$a ;
+print STDERR "The End.\n" ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 6.
+########
+
 --FILE-- abc
 1 if $a EQ $b ;
 1;
@@ -240,3 +276,37 @@ eval '
 print STDERR "The End.\n" ;
 EXPECT
 Use of EQ is deprecated at - line 8.
+########
+
+use warnings 'void' ;
+
+time ;
+
+{
+    use warnings FATAL => qw(void) ;
+    length "abc" ;
+}
+
+join "", 1,2,3 ;
+
+print "done\n" ;
+EXPECT
+Useless use of time in void context at - line 4.
+Useless use of length in void context at - line 8.
+########
+
+use warnings ;
+
+time ;
+
+{
+    use warnings FATAL => qw(void) ;
+    length "abc" ;
+}
+
+join "", 1,2,3 ;
+
+print "done\n" ;
+EXPECT
+Useless use of time in void context at - line 4.
+Useless use of length in void context at - line 8.
diff --git a/contrib/perl5/t/pragma/warn/9enabled b/contrib/perl5/t/pragma/warn/9enabled
index 7facf996f5fd..f5579b2dded9 100755
--- a/contrib/perl5/t/pragma/warn/9enabled
+++ b/contrib/perl5/t/pragma/warn/9enabled
@@ -332,7 +332,17 @@ print $@ ;
 EXPECT
 Usage: warnings::warn([category,] 'message') at - line 4
 unknown warnings category 'fred' at - line 6
-	require 0 called at - line 6
+########
+
+# check warnings::warnif
+use warnings ;
+eval { warnings::warnif() } ;
+print $@ ;
+eval { warnings::warnif("fred", "joe") } ;
+print $@ ;
+EXPECT
+Usage: warnings::warnif([category,] 'message') at - line 4
+unknown warnings category 'fred' at - line 6
 ########
 
 --FILE-- abc.pm
@@ -373,6 +383,7 @@ eval { abc::check() ; } ;
 print "[[$@]]\n";
 EXPECT
 hello at - line 3
+	eval {...} called at - line 3
 [[]]
 ########
 
@@ -388,6 +399,7 @@ eval { abc::check() ; } ;
 print "[[$@]]\n";
 EXPECT
 [[hello at - line 3
+	eval {...} called at - line 3
 ]]
 ########
 -W
@@ -431,7 +443,37 @@ use warnings 'syntax' ;
 use abc ;
 abc::check() ;
 EXPECT
-package 'abc' not registered for warnings at - line 3
+package 'abc' not registered for warnings at abc.pm line 4
+########
+
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+sub check {
+  warnings::warn("fred") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+abc::check() ;
+EXPECT
+package 'abc' not registered for warnings at abc.pm line 4
+########
+
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+sub check {
+  warnings::warnif("fred") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+abc::check() ;
+EXPECT
+package 'abc' not registered for warnings at abc.pm line 4
 ########
 
 --FILE-- abc.pm
@@ -617,6 +659,7 @@ eval { abc::check() ; } ;
 print "[[$@]]\n";
 EXPECT
 hello at - line 3
+	eval {...} called at - line 3
 [[]]
 ########
 
@@ -632,6 +675,7 @@ eval { abc::check() ; } ;
 print "[[$@]]\n";
 EXPECT
 [[hello at - line 3
+	eval {...} called at - line 3
 ]]
 ########
 -W
@@ -723,6 +767,10 @@ sub check {
   print "ok1\n" if !warnings::enabled() ;
   print "ok2\n" if !warnings::enabled("io") ;
   print "ok3\n" if !warnings::enabled("all") ;
+  warnings::warnif("my message 1") ;
+  warnings::warnif('abc', "my message 2") ;
+  warnings::warnif('io', "my message 3") ;
+  warnings::warnif('all', "my message 4") ;
 }
 1;
 --FILE-- 
@@ -817,3 +865,298 @@ abc all not enabled
 def self enabled
 def abc not enabled
 def all not enabled
+########
+-w
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+use warnings::register ;
+sub check { 
+  print "ok1\n" if warnings::enabled() ;
+  print "ok2\n" if warnings::enabled("io") ;
+  print "ok3\n" if warnings::enabled("all") ;
+}
+1;
+--FILE-- 
+use abc ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+-w
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+use warnings::register ;
+sub check { 
+  print "ok1\n" if !warnings::enabled() ;
+  print "ok2\n" if !warnings::enabled("io") ;
+  print "ok3\n" if !warnings::enabled("all") ;
+}
+1;
+--FILE-- 
+use abc ;
+use warnings 'abc';
+no warnings ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+use warnings::register ;
+sub check { 
+  print "ok1\n" if !warnings::enabled() ;
+  print "ok2\n" if !warnings::enabled("io") ;
+  print "ok3\n" if !warnings::enabled("all") ;
+  warnings::warnif("my message 1") ;
+  warnings::warnif('abc', "my message 2") ;
+  warnings::warnif('io', "my message 3") ;
+  warnings::warnif('all', "my message 4") ;
+}
+1;
+--FILE-- 
+use abc ;
+use warnings 'abc';
+no warnings ;
+BEGIN { $^W = 1 ; }
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+use warnings::register ;
+sub check { 
+  print "ok1\n" if !warnings::enabled() ;
+  print "ok2\n" if !warnings::enabled("io") ;
+  print "ok3\n" if !warnings::enabled("all") ;
+}
+1;
+--FILE-- 
+use abc ;
+use warnings 'abc';
+no warnings ;
+$^W = 1 ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+$| = 1;
+package abc ;
+no warnings ;
+use warnings::register ;
+sub check { 
+  print "ok1\n" if  warnings::enabled() ;
+  print "ok2\n" if !warnings::enabled("io") ;
+  print "ok3\n" if !warnings::enabled("all") ;
+  print "ok4\n" if  warnings::enabled("abc") ;
+  warnings::warn("my message 1") ;
+  warnings::warnif("my message 2") ;
+  warnings::warnif('abc', "my message 3") ;
+  warnings::warnif('io', "my message 4") ;
+  warnings::warnif('all', "my message 5") ;
+}
+sub in2 { no warnings ; check() }
+sub in1 { no warnings ; in2() }
+1;
+--FILE-- 
+use abc ;
+use warnings 'abc';
+abc::in1() ;
+EXPECT
+ok1
+ok2
+ok3
+ok4
+my message 1 at - line 3
+my message 2 at - line 3
+my message 3 at - line 3
+########
+
+--FILE-- def.pm
+package def ;
+no warnings ;
+use warnings::register ;
+sub check { 
+  print "ok1\n" if  warnings::enabled() ;
+  print "ok2\n" if !warnings::enabled("io") ;
+  print "ok3\n" if !warnings::enabled("all") ;
+  print "ok4\n" if  warnings::enabled("def") ;
+  warnings::warn("my message 1") ;
+  warnings::warnif("my message 2") ;
+  warnings::warnif('def', "my message 3") ;
+  warnings::warnif('io', "my message 4") ;
+  warnings::warnif('all', "my message 5") ;
+}
+sub in2 { no warnings ; check() }
+sub in1 { no warnings ; in2() }
+1;
+--FILE-- abc.pm
+$| = 1;
+package abc ;
+use def ;
+use warnings 'def';
+sub in1 { def::in1() ; }
+1;
+--FILE-- 
+use abc ;
+no warnings;
+abc::in1() ;
+EXPECT
+ok1
+ok2
+ok3
+ok4
+my message 1 at abc.pm line 5
+	abc::in1() called at - line 3
+my message 2 at abc.pm line 5
+	abc::in1() called at - line 3
+my message 3 at abc.pm line 5
+	abc::in1() called at - line 3
+########
+
+--FILE-- def.pm
+$| = 1;
+package def ;
+no warnings ;
+use warnings::register ;
+require Exporter;
+@ISA = qw( Exporter ) ;
+@EXPORT = qw( in1 ) ;
+sub check { 
+  print "ok1\n" if  warnings::enabled() ;
+  print "ok2\n" if !warnings::enabled("io") ;
+  print "ok3\n" if !warnings::enabled("all") ;
+  print "ok4\n" if  warnings::enabled("abc") ;
+  print "ok5\n" if !warnings::enabled("def") ;
+  warnings::warn("my message 1") ;
+  warnings::warnif("my message 2") ;
+  warnings::warnif('abc', "my message 3") ;
+  warnings::warnif('def', "my message 4") ;
+  warnings::warnif('io', "my message 5") ;
+  warnings::warnif('all', "my message 6") ;
+}
+sub in2 { no warnings ; check() }
+sub in1 { no warnings ; in2() }
+1;
+--FILE-- abc.pm
+package abc ;
+use warnings::register ;
+use def ;
+#@ISA = qw(def) ;
+1;
+--FILE-- 
+use abc ;
+no warnings;
+use warnings 'abc';
+abc::in1() ;
+EXPECT
+ok2
+ok3
+ok4
+ok5
+my message 1 at - line 4
+my message 3 at - line 4
+########
+
+--FILE-- def.pm
+package def ;
+no warnings ;
+use warnings::register ;
+
+sub new
+{
+    my $class = shift ;
+    bless [], $class ;
+}
+
+sub check 
+{ 
+  my $self = shift ;
+  print "ok1\n" if !warnings::enabled() ;
+  print "ok2\n" if !warnings::enabled("io") ;
+  print "ok3\n" if !warnings::enabled("all") ;
+  print "ok4\n" if  warnings::enabled("abc") ;
+  print "ok5\n" if !warnings::enabled("def") ;
+  print "ok6\n" if  warnings::enabled($self) ;
+
+  warnings::warn("my message 1") ;
+  warnings::warn($self, "my message 2") ;
+
+  warnings::warnif("my message 3") ;
+  warnings::warnif('abc', "my message 4") ;
+  warnings::warnif('def', "my message 5") ;
+  warnings::warnif('io', "my message 6") ;
+  warnings::warnif('all', "my message 7") ;
+  warnings::warnif($self, "my message 8") ;
+}
+sub in2 
+{
+  no warnings ; 
+  my $self = shift ;
+  $self->check() ;
+}
+sub in1 
+{ 
+  no warnings ;
+  my $self = shift ;
+  $self->in2();
+}
+1;
+--FILE-- abc.pm
+$| = 1;
+package abc ;
+use warnings::register ;
+use def ;
+@ISA = qw(def) ;
+sub new
+{
+    my $class = shift ;
+    bless [], $class ;
+}
+
+1;
+--FILE-- 
+use abc ;
+no warnings;
+use warnings 'abc';
+$a = new abc ;
+$a->in1() ;
+print "**\n";
+$b = new def ;
+$b->in1() ;
+EXPECT
+ok1
+ok2
+ok3
+ok4
+ok5
+ok6
+my message 1 at - line 5
+my message 2 at - line 5
+my message 4 at - line 5
+my message 8 at - line 5
+**
+ok1
+ok2
+ok3
+ok4
+ok5
+my message 1 at - line 8
+my message 2 at - line 8
+my message 4 at - line 8
diff --git a/contrib/perl5/t/pragma/warn/doio b/contrib/perl5/t/pragma/warn/doio
index bd409721d265..2a357e275575 100644
--- a/contrib/perl5/t/pragma/warn/doio
+++ b/contrib/perl5/t/pragma/warn/doio
@@ -12,22 +12,22 @@
   warn(warn_nl, "open");		[Perl_do_open9]
     open(F, "true\ncd")
 
-  Close on unopened file <%s>		[Perl_do_close] <<TODO
+  close() on unopened filehandle %s	[Perl_do_close]
     $a = "fred";close("$a")
 
-  tell() on unopened file		[Perl_do_tell]
+  tell() on closed filehandle		[Perl_do_tell]
     $a = "fred";$a = tell($a)
 
-  seek() on unopened file		[Perl_do_seek]
+  seek() on closed filehandle		[Perl_do_seek]
     $a = "fred";$a = seek($a,1,1)
 
-  sysseek() on unopened file		[Perl_do_sysseek]
+  sysseek() on closed filehandle	[Perl_do_sysseek]
     $a = "fred";$a = seek($a,1,1)
 
   warn(warn_uninit);			[Perl_do_print]
     print $a ;
 
-  Stat on unopened file <%s> 		[Perl_my_stat]
+  -x on closed filehandle %s 		[Perl_my_stat]
     close STDIN ; -x STDIN ;
 
   warn(warn_nl, "stat");		[Perl_my_stat]
@@ -96,7 +96,7 @@ close "fred" ;
 no warnings 'unopened' ;
 close "joe" ;
 EXPECT
-Close on unopened file <fred> at - line 3.
+close() on unopened filehandle fred at - line 3.
 ########
 # doio.c [Perl_do_tell Perl_do_seek Perl_do_sysseek Perl_my_stat]
 use warnings 'io' ;
@@ -105,17 +105,35 @@ tell(STDIN);
 $a = seek(STDIN,1,1);
 $a = sysseek(STDIN,1,1);
 -x STDIN ;
+stat(STDIN) ;
+$a = "fred";
+tell($a);
+seek($a,1,1);
+sysseek($a,1,1);
+-x $a; # ok
+stat($a); # ok
 no warnings 'io' ;
 close STDIN ;
 tell(STDIN);
 $a = seek(STDIN,1,1);
 $a = sysseek(STDIN,1,1);
 -x STDIN ;
+stat(STDIN) ;
+$a = "fred";
+tell($a);
+seek($a,1,1);
+sysseek($a,1,1);
+-x $a;
+stat($a);
 EXPECT
-tell() on unopened file at - line 4.
-seek() on unopened file at - line 5.
-sysseek() on unopened file at - line 6.
-Stat on unopened file <STDIN> at - line 7.
+tell() on closed filehandle STDIN at - line 4.
+seek() on closed filehandle STDIN at - line 5.
+sysseek() on closed filehandle STDIN at - line 6.
+-x on closed filehandle STDIN at - line 7.
+stat() on closed filehandle STDIN at - line 8.
+tell() on unopened filehandle at - line 10.
+seek() on unopened filehandle at - line 11.
+sysseek() on unopened filehandle at - line 12.
 ########
 # doio.c [Perl_do_print]
 use warnings 'uninitialized' ;
@@ -188,4 +206,4 @@ my $a = eof STDOUT ;
 no warnings 'io' ;
 $a = eof STDOUT ;
 EXPECT
-Filehandle main::STDOUT opened only for output at - line 3.
+Filehandle STDOUT opened only for output at - line 3.
diff --git a/contrib/perl5/t/pragma/warn/op b/contrib/perl5/t/pragma/warn/op
index 1a79b4ad23c4..1f41a98d6244 100644
--- a/contrib/perl5/t/pragma/warn/op
+++ b/contrib/perl5/t/pragma/warn/op
@@ -150,6 +150,17 @@ EXPECT
 # op.c
 use warnings 'closure' ;
 sub x {
+      our $x;
+      sub y {
+         $x
+      }
+   }
+EXPECT
+
+########
+# op.c
+use warnings 'closure' ;
+sub x {
       my $x;
       sub y {
          sub { $x }
@@ -267,7 +278,7 @@ Useless use of hash element in void context at - line 29.
 Useless use of hash slice in void context at - line 30.
 Useless use of unpack in void context at - line 31.
 Useless use of pack in void context at - line 32.
-Useless use of join in void context at - line 33.
+Useless use of join or string in void context at - line 33.
 Useless use of list slice in void context at - line 34.
 Useless use of sort in void context at - line 37.
 Useless use of reverse in void context at - line 38.
@@ -558,7 +569,7 @@ Useless use of a constant in void context at - line 3.
 Useless use of a constant in void context at - line 4.
 ########
 # op.c
-BEGIN{ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } # known scalar leak
+#
 use warnings 'misc' ;
 my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
 @a =~ /abc/ ;
@@ -592,7 +603,6 @@ my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
 EXPECT
 Applying pattern match (m//) to @array will act on scalar(@array) at - line 5.
 Applying substitution (s///) to @array will act on scalar(@array) at - line 6.
-Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;"
 Applying transliteration (tr///) to @array will act on scalar(@array) at - line 7.
 Applying pattern match (m//) to @array will act on scalar(@array) at - line 8.
 Applying substitution (s///) to @array will act on scalar(@array) at - line 9.
@@ -603,6 +613,7 @@ Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 13
 Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 14.
 Applying substitution (s///) to %hash will act on scalar(%hash) at - line 15.
 Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16.
+Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;"
 BEGIN not safe after errors--compilation aborted at - line 18.
 ########
 # op.c
diff --git a/contrib/perl5/t/pragma/warn/perl b/contrib/perl5/t/pragma/warn/perl
index 45807499d6ae..b4a00bac4171 100644
--- a/contrib/perl5/t/pragma/warn/perl
+++ b/contrib/perl5/t/pragma/warn/perl
@@ -54,4 +54,19 @@ Name "main::z" used only once: possible typo at - line 6.
 use warnings 'once' ;
 $x = 3 ;
 EXPECT
+########
 
+# perl.c
+{ use warnings 'once' ; $x = 3 ; }
+$y = 3 ;
+EXPECT
+Name "main::x" used only once: possible typo at - line 3.
+########
+
+# perl.c
+$z = 3 ;
+BEGIN { $^W = 1 }
+{ no warnings 'once' ; $x = 3 ; }
+$y = 3 ;
+EXPECT
+Name "main::y" used only once: possible typo at - line 6.
diff --git a/contrib/perl5/t/pragma/warn/pp_ctl b/contrib/perl5/t/pragma/warn/pp_ctl
index 0deccd35e277..ac01f277b1fa 100644
--- a/contrib/perl5/t/pragma/warn/pp_ctl
+++ b/contrib/perl5/t/pragma/warn/pp_ctl
@@ -214,4 +214,17 @@ DESTROY { die "@{$_[0]} foo bar" }
 { bless ['A'], 'Foo' for 1..10 }
 { bless ['B'], 'Foo' for 1..10 }
 EXPECT
-
+########
+# pp_ctl.c
+use warnings;
+eval 'print $foo';
+EXPECT
+Use of uninitialized value in print at (eval 1) line 1.
+########
+# pp_ctl.c
+use warnings;
+{
+    no warnings;
+    eval 'print $foo';
+}
+EXPECT
diff --git a/contrib/perl5/t/pragma/warn/pp_hot b/contrib/perl5/t/pragma/warn/pp_hot
index 275905749eda..698255c064b0 100644
--- a/contrib/perl5/t/pragma/warn/pp_hot
+++ b/contrib/perl5/t/pragma/warn/pp_hot
@@ -1,6 +1,6 @@
   pp_hot.c	
 
-  Filehandle %s never opened			[pp_print]
+  print() on unopened filehandle abc		[pp_print]
     $f = $a = "abc" ; print $f $a
 
   Filehandle %s opened only for input		[pp_print]
@@ -33,6 +33,9 @@
   readline() on closed filehandle %s		[Perl_do_readline]
     close STDIN ; $a = <STDIN>;
 
+  readline() on closed filehandle %s		[Perl_do_readline]
+    readline(NONESUCH);
+
   glob failed (child exited with status %d%s)	[Perl_do_readline] <<TODO
 
   Deep recursion on subroutine \"%s\"		[Perl_sub_crush_depth]
@@ -52,7 +55,7 @@ print $f $a;
 no warnings 'unopened' ;
 print $f $a;
 EXPECT
-Filehandle main::abc never opened at - line 4.
+print() on unopened filehandle abc at - line 4.
 ########
 # pp_hot.c [pp_print]
 use warnings 'io' ;
@@ -71,12 +74,12 @@ print getc(FOO);
 no warnings 'io' ;
 print STDIN "anc";
 EXPECT
-Filehandle main::STDIN opened only for input at - line 3.
-Filehandle main::STDOUT opened only for output at - line 4.
-Filehandle main::STDERR opened only for output at - line 5.
-Filehandle main::FOO opened only for output at - line 6.
-Filehandle main::STDERR opened only for output at - line 7.
-Filehandle main::FOO opened only for output at - line 8.
+Filehandle STDIN opened only for input at - line 3.
+Filehandle STDOUT opened only for output at - line 4.
+Filehandle STDERR opened only for output at - line 5.
+Filehandle FOO opened only for output at - line 6.
+Filehandle STDERR opened only for output at - line 7.
+Filehandle FOO opened only for output at - line 8.
 ########
 # pp_hot.c [pp_print]
 use warnings 'closed' ;
@@ -90,9 +93,9 @@ print STDIN "anc";
 opendir STDIN, ".";
 print STDIN "anc";
 EXPECT
-print() on closed filehandle main::STDIN at - line 4.
-print() on closed filehandle main::STDIN at - line 6.
-	(Are you trying to call print() on dirhandle main::STDIN?)
+print() on closed filehandle STDIN at - line 4.
+print() on closed filehandle STDIN at - line 6.
+	(Are you trying to call print() on dirhandle STDIN?)
 ########
 # pp_hot.c [pp_rv2av]
 use warnings 'uninitialized' ;
@@ -137,9 +140,9 @@ no warnings 'closed' ;
 opendir STDIN, "." ; $a = <STDIN> ;
 $a = <STDIN> ;
 EXPECT
-readline() on closed filehandle main::STDIN at - line 3.
-readline() on closed filehandle main::STDIN at - line 4.
-	(Are you trying to call readline() on dirhandle main::STDIN?)
+readline() on closed filehandle STDIN at - line 3.
+readline() on closed filehandle STDIN at - line 4.
+	(Are you trying to call readline() on dirhandle STDIN?)
 ########
 # pp_hot.c [Perl_do_readline]
 use warnings 'io' ;
@@ -148,9 +151,10 @@ open (FH, ">./xcv") ;
 my $a = <FH> ;
 no warnings 'io' ;
 $a = <FH> ;
+close (FH) ;
 unlink $file ;
 EXPECT
-Filehandle main::FH opened only for output at - line 5.
+Filehandle FH opened only for output at - line 5.
 ########
 # pp_hot.c [Perl_sub_crush_depth]
 use warnings 'recursion' ;
diff --git a/contrib/perl5/t/pragma/warn/pp_sys b/contrib/perl5/t/pragma/warn/pp_sys
index 7c38727e28eb..68518e29f5cd 100644
--- a/contrib/perl5/t/pragma/warn/pp_sys
+++ b/contrib/perl5/t/pragma/warn/pp_sys
@@ -16,7 +16,7 @@
 
   page overflow	 				[pp_leavewrite]
 
-  Filehandle %s never opened			[pp_prtf]
+  printf() on unopened filehandle abc		[pp_prtf]
     $a = "abc"; printf $a "fred"
 
   Filehandle %s opened only for input		[pp_prtf]
@@ -69,13 +69,16 @@
     getpeername STDIN;
 
   flock() on closed socket %s			[pp_flock]
+  flock() on closed socket			[pp_flock]
     close STDIN;
     flock STDIN, 8;
+    flock $a, 8;
 
   warn(warn_nl, "stat");			[pp_stat]
 
-  Test on unopened file <%s>
-	close STDIN ; -T STDIN ;
+  -T on closed filehandle %s
+  stat() on closed filehandle %s
+	close STDIN ; -T STDIN ; stat(STDIN) ;
 
   warn(warn_nl, "open");			[pp_fttext]
     -T "abc\ndef" ;
@@ -107,7 +110,7 @@ write STDIN;
 no warnings 'io' ;
 write STDIN;
 EXPECT
-Filehandle main::STDIN opened only for input at - line 5.
+Filehandle STDIN opened only for input at - line 5.
 ########
 # pp_sys.c [pp_leavewrite]
 use warnings 'closed' ;
@@ -123,9 +126,9 @@ write STDIN;
 opendir STDIN, ".";
 write STDIN;
 EXPECT
-write() on closed filehandle main::STDIN at - line 6.
-write() on closed filehandle main::STDIN at - line 8.
-	(Are you trying to call write() on dirhandle main::STDIN?)
+write() on closed filehandle STDIN at - line 6.
+write() on closed filehandle STDIN at - line 8.
+	(Are you trying to call write() on dirhandle STDIN?)
 ########
 # pp_sys.c [pp_leavewrite]
 use warnings 'io' ;
@@ -152,7 +155,7 @@ printf $a "fred";
 no warnings 'unopened' ;
 printf $a "fred";
 EXPECT
-Filehandle main::abc never opened at - line 4.
+printf() on unopened filehandle abc at - line 4.
 ########
 # pp_sys.c [pp_prtf]
 use warnings 'closed' ;
@@ -166,9 +169,9 @@ printf STDIN "fred";
 opendir STDIN, ".";
 printf STDIN "fred";
 EXPECT
-printf() on closed filehandle main::STDIN at - line 4.
-printf() on closed filehandle main::STDIN at - line 6.
-	(Are you trying to call printf() on dirhandle main::STDIN?)
+printf() on closed filehandle STDIN at - line 4.
+printf() on closed filehandle STDIN at - line 6.
+	(Are you trying to call printf() on dirhandle STDIN?)
 ########
 # pp_sys.c [pp_prtf]
 use warnings 'io' ;
@@ -176,7 +179,7 @@ printf STDIN "fred";
 no warnings 'io' ;
 printf STDIN "fred";
 EXPECT
-Filehandle main::STDIN opened only for input at - line 3.
+Filehandle STDIN opened only for input at - line 3.
 ########
 # pp_sys.c [pp_send]
 use warnings 'closed' ;
@@ -190,14 +193,16 @@ syswrite STDIN, "fred", 1;
 opendir STDIN, ".";
 syswrite STDIN, "fred", 1;
 EXPECT
-syswrite() on closed filehandle main::STDIN at - line 4.
-syswrite() on closed filehandle main::STDIN at - line 6.
-	(Are you trying to call syswrite() on dirhandle main::STDIN?)
+syswrite() on closed filehandle STDIN at - line 4.
+syswrite() on closed filehandle STDIN at - line 6.
+	(Are you trying to call syswrite() on dirhandle STDIN?)
 ########
 # pp_sys.c [pp_flock]
 use Config; 
 BEGIN { 
-  if ( $^O eq 'VMS' and ! $Config{d_flock}) {
+  if ( !$Config{d_flock} &&
+       !$Config{d_fcntl_can_lock} &&
+       !$Config{d_lockf} ) {
     print <<EOM ;
 SKIPPED
 # flock not present
@@ -205,19 +210,25 @@ EOM
     exit ;
   } 
 }
-use warnings 'closed' ;
+use warnings qw(unopened closed);
 close STDIN;
 flock STDIN, 8;
 opendir STDIN, ".";
 flock STDIN, 8;
-no warnings 'closed' ;
+flock FOO, 8;
+flock $a, 8;
+no warnings qw(unopened closed);
 flock STDIN, 8;
 opendir STDIN, ".";
 flock STDIN, 8;
+flock FOO, 8;
+flock $a, 8;
 EXPECT
-flock() on closed filehandle main::STDIN at - line 14.
-flock() on closed filehandle main::STDIN at - line 16.
-	(Are you trying to call flock() on dirhandle main::STDIN?)
+flock() on closed filehandle STDIN at - line 16.
+flock() on closed filehandle STDIN at - line 18.
+	(Are you trying to call flock() on dirhandle STDIN?)
+flock() on unopened filehandle FOO at - line 19.
+flock() on unopened filehandle at - line 20.
 ########
 # pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername]
 use warnings 'io' ;
@@ -285,36 +296,36 @@ getsockopt STDIN, 1,2;
 getsockname STDIN;
 getpeername STDIN;
 EXPECT
-send() on closed socket main::STDIN at - line 22.
-bind() on closed socket main::STDIN at - line 23.
-connect() on closed socket main::STDIN at - line 24.
-listen() on closed socket main::STDIN at - line 25.
-accept() on closed socket main::STDIN at - line 26.
-shutdown() on closed socket main::STDIN at - line 27.
-setsockopt() on closed socket main::STDIN at - line 28.
-getsockopt() on closed socket main::STDIN at - line 29.
-getsockname() on closed socket main::STDIN at - line 30.
-getpeername() on closed socket main::STDIN at - line 31.
-send() on closed socket main::STDIN at - line 33.
-	(Are you trying to call send() on dirhandle main::STDIN?)
-bind() on closed socket main::STDIN at - line 34.
-	(Are you trying to call bind() on dirhandle main::STDIN?)
-connect() on closed socket main::STDIN at - line 35.
-	(Are you trying to call connect() on dirhandle main::STDIN?)
-listen() on closed socket main::STDIN at - line 36.
-	(Are you trying to call listen() on dirhandle main::STDIN?)
-accept() on closed socket main::STDIN at - line 37.
-	(Are you trying to call accept() on dirhandle main::STDIN?)
-shutdown() on closed socket main::STDIN at - line 38.
-	(Are you trying to call shutdown() on dirhandle main::STDIN?)
-setsockopt() on closed socket main::STDIN at - line 39.
-	(Are you trying to call setsockopt() on dirhandle main::STDIN?)
-getsockopt() on closed socket main::STDIN at - line 40.
-	(Are you trying to call getsockopt() on dirhandle main::STDIN?)
-getsockname() on closed socket main::STDIN at - line 41.
-	(Are you trying to call getsockname() on dirhandle main::STDIN?)
-getpeername() on closed socket main::STDIN at - line 42.
-	(Are you trying to call getpeername() on dirhandle main::STDIN?)
+send() on closed socket STDIN at - line 22.
+bind() on closed socket STDIN at - line 23.
+connect() on closed socket STDIN at - line 24.
+listen() on closed socket STDIN at - line 25.
+accept() on closed socket STDIN at - line 26.
+shutdown() on closed socket STDIN at - line 27.
+setsockopt() on closed socket STDIN at - line 28.
+getsockopt() on closed socket STDIN at - line 29.
+getsockname() on closed socket STDIN at - line 30.
+getpeername() on closed socket STDIN at - line 31.
+send() on closed socket STDIN at - line 33.
+	(Are you trying to call send() on dirhandle STDIN?)
+bind() on closed socket STDIN at - line 34.
+	(Are you trying to call bind() on dirhandle STDIN?)
+connect() on closed socket STDIN at - line 35.
+	(Are you trying to call connect() on dirhandle STDIN?)
+listen() on closed socket STDIN at - line 36.
+	(Are you trying to call listen() on dirhandle STDIN?)
+accept() on closed socket STDIN at - line 37.
+	(Are you trying to call accept() on dirhandle STDIN?)
+shutdown() on closed socket STDIN at - line 38.
+	(Are you trying to call shutdown() on dirhandle STDIN?)
+setsockopt() on closed socket STDIN at - line 39.
+	(Are you trying to call setsockopt() on dirhandle STDIN?)
+getsockopt() on closed socket STDIN at - line 40.
+	(Are you trying to call getsockopt() on dirhandle STDIN?)
+getsockname() on closed socket STDIN at - line 41.
+	(Are you trying to call getsockname() on dirhandle STDIN?)
+getpeername() on closed socket STDIN at - line 42.
+	(Are you trying to call getpeername() on dirhandle STDIN?)
 ########
 # pp_sys.c [pp_stat]
 use warnings 'newline' ;
@@ -325,13 +336,22 @@ EXPECT
 Unsuccessful stat on filename containing newline at - line 3.
 ########
 # pp_sys.c [pp_fttext]
-use warnings 'unopened' ;
+use warnings qw(unopened closed) ;
 close STDIN ; 
 -T STDIN ;
-no warnings 'unopened' ;
+stat(STDIN) ;
+-T HOCUS;
+stat(POCUS);
+no warnings qw(unopened closed) ;
 -T STDIN ;
+stat(STDIN);
+-T HOCUS;
+stat(POCUS);
 EXPECT
-Test on unopened file <STDIN> at - line 4.
+-T on closed filehandle STDIN at - line 4.
+stat() on closed filehandle STDIN at - line 5.
+-T on unopened filehandle HOCUS at - line 6.
+stat() on unopened filehandle POCUS at - line 7.
 ########
 # pp_sys.c [pp_fttext]
 use warnings 'newline' ;
@@ -343,6 +363,13 @@ Unsuccessful open on filename containing newline at - line 3.
 ########
 # pp_sys.c [pp_sysread]
 use warnings 'io' ;
+if ($^O eq 'dos') {
+    print <<EOM ;
+SKIPPED
+# skipped on dos
+EOM
+    exit ;
+}
 my $file = "./xcv" ;
 open(F, ">$file") ; 
 my $a = sysread(F, $a,10) ;
@@ -351,4 +378,4 @@ my $a = sysread(F, $a,10) ;
 close F ;
 unlink $file ;
 EXPECT
-Filehandle main::F opened only for output at - line 5.
+Filehandle F opened only for output at - line 12.
diff --git a/contrib/perl5/t/pragma/warn/regcomp b/contrib/perl5/t/pragma/warn/regcomp
index 5d0c291ea042..8b86b5082fba 100644
--- a/contrib/perl5/t/pragma/warn/regcomp
+++ b/contrib/perl5/t/pragma/warn/regcomp
@@ -11,10 +11,6 @@
 
   Character class [:%.*s:] unknown	[S_regpposixcc]
 
-  Character class syntax [. .] is reserved for future extensions [S_regpposixcc]
-
-  Character class syntax [= =] is reserved for future extensions [S_checkposixcc]
-
   Character class syntax [%c %c] belongs inside character classes [S_checkposixcc] 
   
   /%.127s/: false [] range \"%*.*s\" in regexp [S_regclass]
@@ -33,7 +29,7 @@ $a =~ /(?=a)*/ ;
 no warnings 'regexp' ;
 $a =~ /(?=a)*/ ;
 EXPECT
-(?=a)* matches null string many times at - line 4.
+(?=a)* matches null string many times before HERE mark in regex m/(?=a)* << HERE / at - line 4.
 ########
 # regcomp.c [S_study_chunk]
 use warnings 'regexp' ;
@@ -42,7 +38,7 @@ $_ = "" ;
 no warnings 'regexp' ;
 /(?=a)?/;
 EXPECT
-Strange *+?{} on zero-length expression at - line 4.
+Quantifier unexpected on zero-length expression before HERE mark in regex m/(?=a)? << HERE / at - line 4.
 ########
 # regcomp.c [S_regatom]
 $x = '\m' ;
@@ -51,39 +47,44 @@ $a =~ /a$x/ ;
 no warnings 'regexp' ;
 $a =~ /a$x/ ;
 EXPECT
-/a\m/: Unrecognized escape \m passed through at - line 4.
+Unrecognized escape \m passed through before HERE mark in regex m/a\m << HERE / at - line 4.
 ########
 # regcomp.c [S_regpposixcc S_checkposixcc]
-BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 }
+#
 use warnings 'regexp' ;
 $_ = "" ;
 /[:alpha:]/;
-/[.bar.]/;
-/[=zog=]/;
-/[[:alpha:]]/;
-/[[.foo.]]/;
-/[[=bar=]]/;
 /[:zog:]/;
 /[[:zog:]]/;
 no warnings 'regexp' ;
 /[:alpha:]/;
-/[.foo.]/;
-/[=bar=]/;
-/[[:alpha:]]/;
-/[[.foo.]]/;
-/[[=bar=]]/;
-/[[:zog:]]/;
 /[:zog:]/;
+/[[:zog:]]/;
 EXPECT
-Character class syntax [: :] belongs inside character classes at - line 5.
-Character class syntax [. .] belongs inside character classes at - line 6.
-Character class syntax [. .] is reserved for future extensions at - line 6.
-Character class syntax [= =] belongs inside character classes at - line 7.
-Character class syntax [= =] is reserved for future extensions at - line 7.
-Character class syntax [. .] is reserved for future extensions at - line 9.
-Character class syntax [= =] is reserved for future extensions at - line 10.
-Character class syntax [: :] belongs inside character classes at - line 11.
-Character class [:zog:] unknown at - line 12.
+POSIX syntax [: :] belongs inside character classes before HERE mark in regex m/[:alpha:] << HERE / at - line 5.
+POSIX syntax [: :] belongs inside character classes before HERE mark in regex m/[:zog:] << HERE / at - line 6.
+POSIX class [:zog:] unknown before HERE mark in regex m/[[:zog:] << HERE ]/
+########
+# regcomp.c [S_checkposixcc]
+#
+use warnings 'regexp' ;
+$_ = "" ;
+/[.zog.]/;
+no warnings 'regexp' ;
+/[.zog.]/;
+EXPECT
+POSIX syntax [. .] belongs inside character classes before HERE mark in regex m/[.zog.] << HERE / at - line 5.
+POSIX syntax [. .] is reserved for future extensions before HERE mark in regex m/[.zog.] << HERE /
+########
+# regcomp.c [S_checkposixcc]
+#
+use warnings 'regexp' ;
+$_ = "" ;
+/[[.zog.]]/;
+no warnings 'regexp' ;
+/[[.zog.]]/;
+EXPECT
+POSIX syntax [. .] is reserved for future extensions before HERE mark in regex m/[[.zog.] << HERE ]/
 ########
 # regcomp.c [S_regclass]
 $_ = "";
@@ -108,14 +109,14 @@ no warnings 'regexp' ;
 /[[:alpha:]-[:digit:]]/;
 /[[:digit:]-[:alpha:]]/;
 EXPECT
-/[a-\d]/: false [] range "a-\d" in regexp at - line 5.
-/[\d-b]/: false [] range "\d-" in regexp at - line 6.
-/[\s-\d]/: false [] range "\s-" in regexp at - line 7.
-/[\d-\s]/: false [] range "\d-" in regexp at - line 8.
-/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 9.
-/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 10.
-/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 11.
-/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 12.
+False [] range "a-\d" before HERE mark in regex m/[a-\d << HERE ]/ at - line 5.
+False [] range "\d-" before HERE mark in regex m/[\d- << HERE b]/ at - line 6.
+False [] range "\s-" before HERE mark in regex m/[\s- << HERE \d]/ at - line 7.
+False [] range "\d-" before HERE mark in regex m/[\d- << HERE \s]/ at - line 8.
+False [] range "a-[:digit:]" before HERE mark in regex m/[a-[:digit:] << HERE ]/ at - line 9.
+False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE b]/ at - line 10.
+False [] range "[:alpha:]-" before HERE mark in regex m/[[:alpha:]- << HERE [:digit:]]/ at - line 11.
+False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE [:alpha:]]/ at - line 12.
 ########
 # regcomp.c [S_regclassutf8]
 BEGIN {
@@ -147,14 +148,14 @@ no warnings 'regexp' ;
 /[[:alpha:]-[:digit:]]/;
 /[[:digit:]-[:alpha:]]/;
 EXPECT
-/[a-\d]/: false [] range "a-\d" in regexp at - line 12.
-/[\d-b]/: false [] range "\d-" in regexp at - line 13.
-/[\s-\d]/: false [] range "\s-" in regexp at - line 14.
-/[\d-\s]/: false [] range "\d-" in regexp at - line 15.
-/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 16.
-/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 17.
-/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 18.
-/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 19.
+False [] range "a-\d" before HERE mark in regex m/[a-\d << HERE ]/ at - line 12.
+False [] range "\d-" before HERE mark in regex m/[\d- << HERE b]/ at - line 13.
+False [] range "\s-" before HERE mark in regex m/[\s- << HERE \d]/ at - line 14.
+False [] range "\d-" before HERE mark in regex m/[\d- << HERE \s]/ at - line 15.
+False [] range "a-[:digit:]" before HERE mark in regex m/[a-[:digit:] << HERE ]/ at - line 16.
+False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE b]/ at - line 17.
+False [] range "[:alpha:]-" before HERE mark in regex m/[[:alpha:]- << HERE [:digit:]]/ at - line 18.
+False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE [:alpha:]]/ at - line 19.
 ########
 # regcomp.c [S_regclass S_regclassutf8]
 use warnings 'regexp' ;
@@ -162,4 +163,5 @@ $a =~ /[a\zb]/ ;
 no warnings 'regexp' ;
 $a =~ /[a\zb]/ ;
 EXPECT
-/[a\zb]/: Unrecognized escape \z in character class passed through at - line 3.
+Unrecognized escape \z in character class passed through before HERE mark in regex m/[a\z << HERE b]/ at - line 3.
+
diff --git a/contrib/perl5/t/pragma/warn/sv b/contrib/perl5/t/pragma/warn/sv
index 758137f2e8d7..2409589a8f29 100644
--- a/contrib/perl5/t/pragma/warn/sv
+++ b/contrib/perl5/t/pragma/warn/sv
@@ -178,7 +178,7 @@ no warnings 'uninitialized' ;
 $C = "" ;
 $C .= $A ;
 EXPECT
-Use of uninitialized value in concatenation (.) at - line 10.
+Use of uninitialized value in concatenation (.) or string at - line 10.
 ########
 # sv.c 
 use warnings 'numeric' ;
diff --git a/contrib/perl5/t/pragma/warn/toke b/contrib/perl5/t/pragma/warn/toke
index cfdea78d3c38..fa7132960cf3 100644
--- a/contrib/perl5/t/pragma/warn/toke
+++ b/contrib/perl5/t/pragma/warn/toke
@@ -198,10 +198,6 @@ EXPECT
 Semicolon seems to be missing at - line 3.
 ########
 # toke.c
-BEGIN {
-    # Scalars leaked: due to syntax errors
-    $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
-}
 use warnings 'syntax' ;
 my $a =+ 2 ;
 $a =- 2 ;
@@ -214,25 +210,21 @@ $a =| 2 ;
 $a =< 2 ;
 $a =/ 2 ;
 EXPECT
-Reversed += operator at - line 7.
-Reversed -= operator at - line 8.
-Reversed *= operator at - line 9.
-Reversed %= operator at - line 10.
-Reversed &= operator at - line 11.
-Reversed .= operator at - line 12.
-syntax error at - line 12, near "=."
-Reversed ^= operator at - line 13.
-syntax error at - line 13, near "=^"
-Reversed |= operator at - line 14.
-syntax error at - line 14, near "=|"
-Reversed <= operator at - line 15.
-Unterminated <> operator at - line 15.
-########
-# toke.c
-BEGIN {
-    # Scalars leaked: due to syntax errors
-    $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
-}
+Reversed += operator at - line 3.
+Reversed -= operator at - line 4.
+Reversed *= operator at - line 5.
+Reversed %= operator at - line 6.
+Reversed &= operator at - line 7.
+Reversed .= operator at - line 8.
+Reversed ^= operator at - line 9.
+Reversed |= operator at - line 10.
+Reversed <= operator at - line 11.
+syntax error at - line 8, near "=."
+syntax error at - line 9, near "=^"
+syntax error at - line 10, near "=|"
+Unterminated <> operator at - line 11.
+########
+# toke.c
 no warnings 'syntax' ;
 my $a =+ 2 ;
 $a =- 2 ;
@@ -245,10 +237,10 @@ $a =| 2 ;
 $a =< 2 ;
 $a =/ 2 ;
 EXPECT
-syntax error at - line 12, near "=."
-syntax error at - line 13, near "=^"
-syntax error at - line 14, near "=|"
-Unterminated <> operator at - line 15.
+syntax error at - line 8, near "=."
+syntax error at - line 9, near "=^"
+syntax error at - line 10, near "=|"
+Unterminated <> operator at - line 11.
 ########
 # toke.c
 use warnings 'syntax' ;
@@ -290,6 +282,9 @@ Can't use \1 to mean $1 in expression at - line 4.
 # toke.c
 use warnings 'reserved' ;
 $a = abc;
+$a = { def
+
+=> 1 };
 no warnings 'reserved' ;
 $a = abc;
 EXPECT
@@ -434,13 +429,14 @@ Ambiguous call resolved as CORE::time(), qualify as such or use & at - line 4.
 # toke.c
 use warnings ;
 eval <<'EOE';
+#  line 30 "foo"
+warn "yelp";
 {
-#line 30 "foo"
   $_ = " \x{123} " ;
 }
 EOE
 EXPECT
-
+yelp at foo line 30.
 ########
 # toke.c
 my $a = rand + 4 ;
@@ -581,3 +577,11 @@ EXPECT
 Integer overflow in binary number at - line 5.
 Integer overflow in hexadecimal number at - line 8.
 Integer overflow in octal number at - line 11.
+########
+# toke.c
+use warnings 'ambiguous';
+"@mjd_previously_unused_array";        
+no warnings 'ambiguous';
+"@mjd_previously_unused_array";        
+EXPECT
+Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3.
diff --git a/contrib/perl5/t/pragma/warn/utf8 b/contrib/perl5/t/pragma/warn/utf8
index 6a2fe5446c30..9a7dbafdee84 100644
--- a/contrib/perl5/t/pragma/warn/utf8
+++ b/contrib/perl5/t/pragma/warn/utf8
@@ -15,6 +15,12 @@
 
 __END__
 # utf8.c [utf8_to_uv] -W
+BEGIN {
+    if (ord('A') == 193) {
+        print "SKIPPED\n# ebcdic platforms do not generate Malformed UTF-8 warnings.";
+        exit 0;
+    }
+}
 use utf8 ;
 my $a = "snøstorm" ;
 {
@@ -24,6 +30,6 @@ my $a = "snøstorm" ;
     my $a = "snøstorm";
 }
 EXPECT
-Malformed UTF-8 character at - line 3.
-Malformed UTF-8 character at - line 8.
+Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 9.
+Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 14.
 ########
diff --git a/contrib/perl5/t/pragma/warnings.t b/contrib/perl5/t/pragma/warnings.t
index 71fb0df972e1..66b4ff91607e 100755
--- a/contrib/perl5/t/pragma/warnings.t
+++ b/contrib/perl5/t/pragma/warnings.t
@@ -2,7 +2,7 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    unshift @INC, '../lib';
+    @INC = '../lib';
     $ENV{PERL5LIB} = '../lib';
     require Config; import Config;
 }
@@ -26,9 +26,7 @@ else
 
 foreach (@w_files) {
 
-    next if /\.orig$/ ;
-
-    next if /(~|\.orig)$/;
+    next if /(~|\.orig|,v)$/;
 
     open F, "<$_" or die "Cannot open $_: $!\n" ;
     while (<F>) {