stock perl 5.8.0 from CPAN

169 files changed, 19050 insertions, 468 deletions

diff --git a/gnu/usr.bin/perl/t/TestInit.pm b/gnu/usr.bin/perl/t/TestInit.pm
new file mode 100644
index 00000000000..f33ee1294b1
--- /dev/null
+++ b/gnu/usr.bin/perl/t/TestInit.pm
@@ -0,0 +1,22 @@
+# This is a replacement for the old BEGIN preamble which heads (or
+# should head) up every core test program to prepare it for running.
+# Now instead of:
+#
+# BEGIN {
+#   chdir 't' if -d 't';
+#   @INC = '../lib';
+# }
+#
+# t/TEST will use -MTestInit.  You may "use TestInit" in the test
+# programs but it is not required.
+#
+# P.S. This documentation is not in POD format in order to avoid
+# problems when there are fundamental bugs in perl.
+
+package TestInit;
+
+chdir 't' if -d 't';
+@INC = '../lib';
+$0 =~ s/\.dp$//; # for the test.deparse make target
+1;
+
diff --git a/gnu/usr.bin/perl/t/base/num.t b/gnu/usr.bin/perl/t/base/num.t
new file mode 100644
index 00000000000..97fa3128935
--- /dev/null
+++ b/gnu/usr.bin/perl/t/base/num.t
@@ -0,0 +1,166 @@
+#!./perl
+
+print "1..45\n";
+
+# First test whether the number stringification works okay.
+# (Testing with == would exercize the IV/NV part, not the PV.)
+
+$a = 1; "$a";
+print $a eq "1"       ? "ok 1\n"  : "not ok 1 # $a\n";
+
+$a = -1; "$a";
+print $a eq "-1"      ? "ok 2\n"  : "not ok 2 # $a\n";
+
+$a = 1.; "$a";
+print $a eq "1"       ? "ok 3\n"  : "not ok 3 # $a\n";
+
+$a = -1.; "$a";
+print $a eq "-1"      ? "ok 4\n"  : "not ok 4 # $a\n";
+
+$a = 0.1; "$a";
+print $a eq "0.1"     ? "ok 5\n"  : "not ok 5 # $a\n";
+
+$a = -0.1; "$a";
+print $a eq "-0.1"    ? "ok 6\n"  : "not ok 6 # $a\n";
+
+$a = .1; "$a";
+print $a eq "0.1"     ? "ok 7\n"  : "not ok 7 # $a\n";
+
+$a = -.1; "$a";
+print $a eq "-0.1"    ? "ok 8\n"  : "not ok 8 # $a\n";
+
+$a = 10.01; "$a";
+print $a eq "10.01"   ? "ok 9\n"  : "not ok 9 # $a\n";
+
+$a = 1e3; "$a";
+print $a eq "1000"    ? "ok 10\n" : "not ok 10 # $a\n";
+
+$a = 10.01e3; "$a";
+print $a eq "10010"   ? "ok 11\n"  : "not ok 11 # $a\n";
+
+$a = 0b100; "$a";
+print $a eq "4"       ? "ok 12\n"  : "not ok 12 # $a\n";
+
+$a = 0100; "$a";
+print $a eq "64"      ? "ok 13\n"  : "not ok 13 # $a\n";
+
+$a = 0x100; "$a";
+print $a eq "256"     ? "ok 14\n" : "not ok 14 # $a\n";
+
+$a = 1000; "$a";
+print $a eq "1000"    ? "ok 15\n" : "not ok 15 # $a\n";
+
+# Okay, now test the numerics.
+# We may be assuming too much, given the painfully well-known floating
+# point sloppiness, but the following are still quite reasonable
+# assumptions which if not working would confuse people quite badly.
+
+$a = 1; "$a"; # Keep the stringification as a potential troublemaker.
+print $a + 1 == 2     ? "ok 16\n" : "not ok 16 #" . $a + 1 . "\n";
+# Don't know how useful printing the stringification of $a + 1 really is.
+
+$a = -1; "$a";
+print $a + 1 == 0     ? "ok 17\n" : "not ok 17 #" . $a + 1 . "\n";
+
+$a = 1.; "$a";
+print $a + 1 == 2     ? "ok 18\n" : "not ok 18 #" . $a + 1 . "\n";
+
+$a = -1.; "$a";
+print $a + 1 == 0     ? "ok 19\n" : "not ok 19 #" . $a + 1 . "\n";
+
+sub ok { # Can't assume too much of floating point numbers.
+    my ($a, $b, $c);
+    abs($a - $b) <= $c;
+}
+
+$a = 0.1; "$a";
+print ok($a + 1,  1.1,  0.05)   ? "ok 20\n" : "not ok 20 #" . $a + 1 . "\n";
+
+$a = -0.1; "$a";
+print ok($a + 1,  0.9,  0.05)   ? "ok 21\n" : "not ok 21 #" . $a + 1 . "\n";
+
+$a = .1; "$a";
+print ok($a + 1,  1.1,  0.005)  ? "ok 22\n" : "not ok 22 #" . $a + 1 . "\n";
+
+$a = -.1; "$a";
+print ok($a + 1,  0.9,  0.05)   ? "ok 23\n" : "not ok 23 #" . $a + 1 . "\n";
+
+$a = 10.01; "$a";
+print ok($a + 1, 11.01, 0.005) ? "ok 24\n" : "not ok 24 #" . $a + 1 . "\n";
+
+$a = 1e3; "$a";
+print $a + 1 == 1001  ? "ok 25\n" : "not ok 25 #" . $a + 1 . "\n";
+
+$a = 10.01e3; "$a";
+print $a + 1 == 10011 ? "ok 26\n" : "not ok 26 #" . $a + 1 . "\n";
+
+$a = 0b100; "$a";
+print $a + 1 == 0b101 ? "ok 27\n" : "not ok 27 #" . $a + 1 . "\n";
+
+$a = 0100; "$a";
+print $a + 1 == 0101  ? "ok 28\n" : "not ok 28 #" . $a + 1 . "\n";
+
+$a = 0x100; "$a";
+print $a + 1 == 0x101 ? "ok 29\n" : "not ok 29 #" . $a + 1 . "\n";
+
+$a = 1000; "$a";
+print $a + 1 == 1001  ? "ok 30\n" : "not ok 30 #" . $a + 1 . "\n";
+
+# back to some basic stringify tests
+# we expect NV stringification to work according to C sprintf %.*g rules
+
+if ($^O eq 'os2') { # In the long run, fix this.  For 5.8.0, deal.
+    $a = 0.01; "$a";
+    print $a eq "0.01"   || $a eq '1e-02' ? "ok 31\n" : "not ok 31 # $a\n";
+
+    $a = 0.001; "$a";
+    print $a eq "0.001"  || $a eq '1e-03' ? "ok 32\n" : "not ok 32 # $a\n";
+
+    $a = 0.0001; "$a";
+    print $a eq "0.0001" || $a eq '1e-04' ? "ok 33\n" : "not ok 33 # $a\n";
+} else {
+    $a = 0.01; "$a";
+    print $a eq "0.01"    ? "ok 31\n" : "not ok 31 # $a\n";
+
+    $a = 0.001; "$a";
+    print $a eq "0.001"   ? "ok 32\n" : "not ok 32 # $a\n";
+
+    $a = 0.0001; "$a";
+    print $a eq "0.0001"  ? "ok 33\n" : "not ok 33 # $a\n";
+}
+
+$a = 0.00009; "$a";
+print $a eq "9e-05" || $a eq "9e-005" ? "ok 34\n"  : "not ok 34 # $a\n";
+
+$a = 1.1; "$a";
+print $a eq "1.1"     ? "ok 35\n" : "not ok 35 # $a\n";
+
+$a = 1.01; "$a";
+print $a eq "1.01"    ? "ok 36\n" : "not ok 36 # $a\n";
+
+$a = 1.001; "$a";
+print $a eq "1.001"   ? "ok 37\n" : "not ok 37 # $a\n";
+
+$a = 1.0001; "$a";
+print $a eq "1.0001"  ? "ok 38\n" : "not ok 38 # $a\n";
+
+$a = 1.00001; "$a";
+print $a eq "1.00001" ? "ok 39\n" : "not ok 39 # $a\n";
+
+$a = 1.000001; "$a";
+print $a eq "1.000001" ? "ok 40\n" : "not ok 40 # $a\n";
+
+$a = 0.; "$a";
+print $a eq "0"       ? "ok 41\n" : "not ok 41 # $a\n";
+
+$a = 100000.; "$a";
+print $a eq "100000"  ? "ok 42\n" : "not ok 42 # $a\n";
+
+$a = -100000.; "$a";
+print $a eq "-100000" ? "ok 43\n" : "not ok 43 # $a\n";
+
+$a = 123.456; "$a";
+print $a eq "123.456" ? "ok 44\n" : "not ok 44 # $a\n";
+
+$a = 1e34; "$a";
+print $a eq "1e+34" || $a eq "1e+034" ? "ok 45\n" : "not ok 45 $a\n";
diff --git a/gnu/usr.bin/perl/t/base/rs.t b/gnu/usr.bin/perl/t/base/rs.t
index e470f3a30c1..f89c84e3a08 100644
--- a/gnu/usr.bin/perl/t/base/rs.t
+++ b/gnu/usr.bin/perl/t/base/rs.t
@@ -1,7 +1,7 @@
 #!./perl
 # Test $!
 
-print "1..14\n";
+print "1..16\n";
 
 $teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n";
 
@@ -11,7 +11,7 @@ rmdir 'foo';
 open TESTFILE, ">./foo" or die "error $! $^E opening";
 binmode TESTFILE;
 print TESTFILE $teststring;
-close TESTFILE;
+close TESTFILE or die "error $! $^E closing";
 
 open TESTFILE, "<./foo";
 binmode TESTFILE;
@@ -86,9 +86,7 @@ $/ = \$foo;
 $bar = <TESTFILE>;
 if ($bar eq "78") {print "ok 10\n";} else {print "not ok 10\n";}
 
-# Get rid of the temp file
 close TESTFILE;
-unlink "./foo";
 
 # Now for the tricky bit--full record reading
 if ($^O eq 'VMS') {
@@ -130,3 +128,35 @@ if ($^O eq 'VMS') {
   # put their own tests in) so we just punt
   foreach $test (11..14) {print "ok $test # skipped on non-VMS system\n"};
 }
+
+$/ = "\n";
+
+# see if open/readline/close work on our and my variables
+{
+    if (open our $T, "./foo") {
+        my $line = <$T>;
+	print "# $line\n";
+	length($line) == 40 or print "not ";
+        close $T or print "not ";
+    }
+    else {
+	print "not ";
+    }
+    print "ok 15\n";
+}
+
+{
+    if (open my $T, "./foo") {
+        my $line = <$T>;
+	print "# $line\n";
+	length($line) == 40 or print "not ";
+        close $T or print "not ";
+    }
+    else {
+	print "not ";
+    }
+    print "ok 16\n";
+}
+
+# Get rid of the temp file
+END { unlink "./foo"; }
diff --git a/gnu/usr.bin/perl/t/comp/hints.t b/gnu/usr.bin/perl/t/comp/hints.t
new file mode 100644
index 00000000000..5911b77688f
--- /dev/null
+++ b/gnu/usr.bin/perl/t/comp/hints.t
@@ -0,0 +1,36 @@
+#!./perl -w
+
+BEGIN { print "1..7\n"; }
+BEGIN {
+    print "not " if exists $^H{foo};
+    print "ok 1 - \$^H{foo} doesn't exist initially\n";
+}
+{
+    # simulate a pragma -- don't forget HINT_LOCALIZE_HH
+    BEGIN { $^H |= 0x00020000; $^H{foo} = "a"; }
+    BEGIN {
+	print "not " if $^H{foo} ne "a";
+	print "ok 2 - \$^H{foo} is now 'a'\n";
+    }
+    {
+	BEGIN { $^H |= 0x00020000; $^H{foo} = "b"; }
+	BEGIN {
+	    print "not " if $^H{foo} ne "b";
+	    print "ok 3 - \$^H{foo} is now 'b'\n";
+	}
+    }
+    BEGIN {
+	print "not " if $^H{foo} ne "a";
+	print "ok 4 - \$H^{foo} restored to 'a'\n";
+    }
+    CHECK {
+	print "not " if exists $^H{foo};
+	print "ok 6 - \$^H{foo} doesn't exist when compilation complete\n";
+    }
+    print "not " if exists $^H{foo};
+    print "ok 7 - \$^H{foo} doesn't exist at runtime\n";
+}
+BEGIN {
+    print "not " if exists $^H{foo};
+    print "ok 5 - \$^H{foo} doesn't exist while finishing compilation\n";
+}
diff --git a/gnu/usr.bin/perl/t/io/binmode.t b/gnu/usr.bin/perl/t/io/binmode.t
new file mode 100644
index 00000000000..3775290bf5f
--- /dev/null
+++ b/gnu/usr.bin/perl/t/io/binmode.t
@@ -0,0 +1,30 @@
+#!./perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(. ../lib);
+}
+
+use Config;
+
+require "test.pl";
+plan(tests => 8);
+
+ok( binmode(STDERR),            'STDERR made binary' );
+if (find PerlIO::Layer 'perlio') {
+  ok( binmode(STDERR, ":unix"),   '  with unix discipline' );
+} else {
+  ok(1,   '  skip unix discipline without PerlIO layers' );
+}
+ok( binmode(STDERR, ":raw"),    '  raw' );
+ok( binmode(STDERR, ":crlf"),   '  and crlf' );
+
+# If this one fails, we're in trouble.  So we just bail out.
+ok( binmode(STDOUT),            'STDOUT made binary' )      || exit(1);
+if (find PerlIO::Layer 'perlio') {
+  ok( binmode(STDOUT, ":unix"),   '  with unix discipline' );
+} else {
+  ok(1,   '  skip unix discipline without PerlIO layers' );
+}
+ok( binmode(STDOUT, ":raw"),    '  raw' );
+ok( binmode(STDOUT, ":crlf"),   '  and crlf' );
diff --git a/gnu/usr.bin/perl/t/io/crlf.t b/gnu/usr.bin/perl/t/io/crlf.t
new file mode 100644
index 00000000000..08ab4fe3b09
--- /dev/null
+++ b/gnu/usr.bin/perl/t/io/crlf.t
@@ -0,0 +1,44 @@
+#!./perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(. ../lib);
+}
+
+use Config;
+
+require "test.pl";
+
+my $file = "crlf$$.dat";
+END {
+ unlink($file);
+}
+
+if (find PerlIO::Layer 'perlio') {
+ plan(tests => 7);
+ ok(open(FOO,">:crlf",$file));
+ ok(print FOO 'a'.((('a' x 14).qq{\n}) x 2000) || close(FOO));
+ ok(open(FOO,"<:crlf",$file));
+
+ my $text;
+ { local $/; $text = <FOO> }
+ is(count_chars($text, "\015\012"), 0);
+ is(count_chars($text, "\n"), 2000);
+
+ binmode(FOO);
+ seek(FOO,0,0);
+ { local $/; $text = <FOO> }
+ is(count_chars($text, "\015\012"), 2000);
+
+ ok(close(FOO));
+}
+else {
+ skip_all("No perlio, so no :crlf");
+}
+
+sub count_chars {
+  my($text, $chars) = @_;
+  my $seen = 0;
+  $seen++ while $text =~ /$chars/g;
+  return $seen;
+}
diff --git a/gnu/usr.bin/perl/t/io/fflush.t b/gnu/usr.bin/perl/t/io/fflush.t
new file mode 100644
index 00000000000..fbf6b47fe1e
--- /dev/null
+++ b/gnu/usr.bin/perl/t/io/fflush.t
@@ -0,0 +1,131 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+# Script to test auto flush on fork/exec/system/qx.  The idea is to
+# print "Pe" to a file from a parent process and "rl" to the same file
+# from a child process.  If buffers are flushed appropriately, the
+# file should contain "Perl".  We'll see...
+use Config;
+use warnings;
+use strict;
+
+# This attempts to mirror the #ifdef forest found in perl.h so that we
+# know when to run these tests.  If that forest ever changes, change
+# it here too or expect test gratuitous test failures.
+my $useperlio = defined $Config{useperlio} ? $Config{useperlio} eq 'define' ? 1 : 0 : 0;
+my $fflushNULL = defined $Config{fflushNULL} ? $Config{fflushNULL} eq 'define' ? 1 : 0 : 0;
+my $d_sfio = defined $Config{d_sfio} ? $Config{d_sfio} eq 'define' ? 1 : 0 : 0;
+my $fflushall = defined $Config{fflushall} ? $Config{fflushall} eq 'define' ? 1 : 0 : 0;
+my $d_fork = defined $Config{d_fork} ? $Config{d_fork} eq 'define' ? 1 : 0 : 0;
+
+if ($useperlio || $fflushNULL || $d_sfio) {
+    print "1..4\n";
+} else {
+    if ($fflushall) {
+	print "1..4\n";
+    } else {
+	print "1..0 # Skip: fflush(NULL) or equivalent not available\n";
+        exit;
+    }
+}
+
+my $runperl = qq{$^X "-I../lib"};
+my @delete;
+
+END {
+    for (@delete) {
+	unlink $_ or warn "unlink $_: $!";
+    }
+}
+
+sub file_eq {
+    my $f   = shift;
+    my $val = shift;
+
+    open IN, $f or die "open $f: $!";
+    chomp(my $line = <IN>);
+    close IN;
+
+    print "# got $line\n";
+    print "# expected $val\n";
+    return $line eq $val;
+}
+
+# This script will be used as the command to execute from
+# child processes
+open PROG, "> ff-prog" or die "open ff-prog: $!";
+print PROG <<'EOF';
+my $f = shift;
+my $str = shift;
+open OUT, ">> $f" or die "open $f: $!";
+print OUT $str;
+close OUT;
+EOF
+    ;
+close PROG or die "close ff-prog: $!";;
+push @delete, "ff-prog";
+
+$| = 0; # we want buffered output
+
+# Test flush on fork/exec
+if (!$d_fork) {
+    print "ok 1 # skipped: no fork\n";
+} else {
+    my $f = "ff-fork-$$";
+    open OUT, "> $f" or die "open $f: $!";
+    print OUT "Pe";
+    my $pid = fork;
+    if ($pid) {
+	# Parent
+	wait;
+	close OUT or die "close $f: $!";
+    } elsif (defined $pid) {
+	# Kid
+	print OUT "r";
+	my $command = qq{$runperl "ff-prog" "$f" "l"};
+	print "# $command\n";
+	exec $command or die $!;
+	exit;
+    } else {
+	# Bang
+	die "fork: $!";
+    }
+
+    print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n";
+    push @delete, $f;
+}
+
+# Test flush on system/qx/pipe open
+my %subs = (
+            "system" => sub {
+                my $c = shift;
+                system $c;
+            },
+            "qx"     => sub {
+                my $c = shift;
+                qx{$c};
+            },
+            "popen"  => sub {
+                my $c = shift;
+                open PIPE, "$c|" or die "$c: $!";
+                close PIPE;
+            },
+            );
+my $t = 2;
+for (qw(system qx popen)) {
+    my $code    = $subs{$_};
+    my $f       = "ff-$_-$$";
+    my $command = qq{$runperl "ff-prog" "$f" "rl"};
+    open OUT, "> $f" or die "open $f: $!";
+    print OUT "Pe";
+    close OUT or die "close $f: $!";;
+    print "# $command\n";
+    $code->($command);
+    print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n";
+    push @delete, $f;
+    ++$t;
+}
diff --git a/gnu/usr.bin/perl/t/io/iprefix.t b/gnu/usr.bin/perl/t/io/iprefix.t
index 10a5c5f686a..a845040f3df 100644
--- a/gnu/usr.bin/perl/t/io/iprefix.t
+++ b/gnu/usr.bin/perl/t/io/iprefix.t
@@ -13,12 +13,24 @@ if ($^O eq 'MSWin32') {
   `.\\perl -le "print 'foo'" > .b`;
   `.\\perl -le "print 'foo'" > .c`;
 }
+elsif ($^O eq 'NetWare') {
+  $CAT = 'perl -e "print<>"';
+  `perl -le "print 'foo'" > .a`;
+  `perl -le "print 'foo'" > .b`;
+  `perl -le "print 'foo'" > .c`;
+}
 elsif ($^O eq 'VMS') {
   $CAT = 'MCR []perl. -e "print<>"';
   `MCR []perl. -le "print 'foo'" > ./.a`;
   `MCR []perl. -le "print 'foo'" > ./.b`;
   `MCR []perl. -le "print 'foo'" > ./.c`;
 }
+elsif ($^O eq 'MacOS') {
+  $CAT = "$^X -e \"print<>\"";
+  `$^X -le "print 'foo'" > .a`;
+  `$^X -le "print 'foo'" > .b`;
+  `$^X -le "print 'foo'" > .c`;
+}
 else {
   $CAT = 'cat';
   `echo foo | tee .a .b .c`;
diff --git a/gnu/usr.bin/perl/t/io/openpid.t b/gnu/usr.bin/perl/t/io/openpid.t
index 7c04a29fe81..c6ed8402258 100644
--- a/gnu/usr.bin/perl/t/io/openpid.t
+++ b/gnu/usr.bin/perl/t/io/openpid.t
@@ -10,19 +10,22 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
-    if ($^O eq 'dos') {
-        print "1..0 # Skip: no multitasking\n";
-        exit 0;
-    }
+    require './test.pl';
 }
 
+if ($^O eq 'dos' || $^O eq 'MacOS') {
+    skip_all("no multitasking");
+}
+
+plan tests => 10;
+
+
 use Config;
 $| = 1;
 $SIG{PIPE} = 'IGNORE';
 
-print "1..10\n";
-
-$perl = qq[$^X "-I../lib"];
+my $perl = which_perl();
+$perl .= qq[ "-I../lib"];
 
 #
 # commands run 4 perl programs.  Two of these programs write a
@@ -39,14 +42,10 @@ $cmd4 = qq/$perl -e "print scalar <>;"/;
 #warn "#$cmd1\n#$cmd2\n#$cmd3\n#$cmd4\n";
 
 # start the processes
-$pid1 = open(FH1, "$cmd1 |") or print "not ";
-print "ok 1\n";
-$pid2 = open(FH2, "$cmd2 |") or print "not ";
-print "ok 2\n";
-$pid3 = open(FH3, "| $cmd3") or print "not ";
-print "ok 3\n";
-$pid4 = open(FH4, "| $cmd4") or print "not ";
-print "ok 4\n";
+ok( $pid1 = open(FH1, "$cmd1 |"), 'first process started');
+ok( $pid2 = open(FH2, "$cmd2 |"), '    second' );
+ok( $pid3 = open(FH3, "| $cmd3"), '    third'  );
+ok( $pid4 = open(FH4, "| $cmd4"), '    fourth' );
 
 print "# pids were $pid1, $pid2, $pid3, $pid4\n";
 
@@ -55,28 +54,27 @@ $killsig = 1 unless $Config{sig_name} =~ /\bHUP\b/;
 
 # get message from first process and kill it
 chomp($from_pid1 = scalar(<FH1>));
-print "# child1 returned [$from_pid1]\nnot "
-    unless $from_pid1 eq 'first process';
-print "ok 5\n";
+is( $from_pid1, 'first process',    'message from first process' );
+
 $kill_cnt = kill $killsig, $pid1;
-print "not " unless $kill_cnt == 1;
-print "ok 6\n";
+is( $kill_cnt, 1,   'first process killed' ) ||
+  print "# errno == $!\n";
 
 # get message from second process and kill second process and reader process
 chomp($from_pid2 = scalar(<FH2>));
-print "# child2 returned [$from_pid2]\nnot "
-    unless $from_pid2 eq 'second process';
-print "ok 7\n";
+is( $from_pid2, 'second process',   'message from second process' );
+
 $kill_cnt = kill $killsig, $pid2, $pid3;
-print "not " unless $kill_cnt == 2;
-print "ok 8\n";
+is( $kill_cnt, 2,   'killing procs 2 & 3' ) ||
+  print "# errno == $!\n";
+
 
 # send one expected line of text to child process and then wait for it
 select(FH4); $| = 1; select(STDOUT);
 
-print FH4 "ok 9\n";
+printf FH4 "ok %d - text sent to fourth process\n", curr_test();
+next_test();
 print "# waiting for process $pid4 to exit\n";
 $reap_pid = waitpid $pid4, 0;
-print "# reaped pid $reap_pid != $pid4\nnot "
-    unless $reap_pid == $pid4;         
-print "ok 10\n";
+is( $reap_pid, $pid4, 'fourth process reaped' );
+
diff --git a/gnu/usr.bin/perl/t/io/utf8.t b/gnu/usr.bin/perl/t/io/utf8.t
new file mode 100644
index 00000000000..e1ecf1c4336
--- /dev/null
+++ b/gnu/usr.bin/perl/t/io/utf8.t
@@ -0,0 +1,282 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    unless (find PerlIO::Layer 'perlio') {
+	print "1..0 # Skip: not perlio\n";
+	exit 0;
+    }
+}
+
+no utf8; # needed for use utf8 not griping about the raw octets
+
+$| = 1;
+print "1..31\n";
+
+open(F,"+>:utf8",'a');
+print F chr(0x100).'£';
+print '#'.tell(F)."\n";
+print "not " unless tell(F) == 4;
+print "ok 1\n";
+print F "\n";
+print '#'.tell(F)."\n";
+print "not " unless tell(F) >= 5;
+print "ok 2\n";
+seek(F,0,0);
+print "not " unless getc(F) eq chr(0x100);
+print "ok 3\n";
+print "not " unless getc(F) eq "£";
+print "ok 4\n";
+print "not " unless getc(F) eq "\n";
+print "ok 5\n";
+seek(F,0,0);
+binmode(F,":bytes");
+my $chr = chr(0xc4);
+if (ord('A') == 193) { $chr = chr(0x8c); } # EBCDIC
+print "not " unless getc(F) eq $chr;
+print "ok 6\n";
+$chr = chr(0x80);
+if (ord('A') == 193) { $chr = chr(0x41); } # EBCDIC
+print "not " unless getc(F) eq $chr;
+print "ok 7\n";
+$chr = chr(0xc2);
+if (ord('A') == 193) { $chr = chr(0x80); } # EBCDIC
+print "not " unless getc(F) eq $chr;
+print "ok 8\n";
+$chr = chr(0xa3);
+if (ord('A') == 193) { $chr = chr(0x44); } # EBCDIC
+print "not " unless getc(F) eq $chr;
+print "ok 9\n";
+print "not " unless getc(F) eq "\n";
+print "ok 10\n";
+seek(F,0,0);
+binmode(F,":utf8");
+print "not " unless scalar(<F>) eq "\x{100}£\n";
+print "ok 11\n";
+seek(F,0,0);
+$buf = chr(0x200);
+$count = read(F,$buf,2,1);
+print "not " unless $count == 2;
+print "ok 12\n";
+print "not " unless $buf eq "\x{200}\x{100}£";
+print "ok 13\n";
+close(F);
+
+{
+    $a = chr(300); # This *is* UTF-encoded
+    $b = chr(130); # This is not.
+
+    open F, ">:utf8", 'a' or die $!;
+    print F $a,"\n";
+    close F;
+
+    open F, "<:utf8", 'a' or die $!;
+    $x = <F>;
+    chomp($x);
+    print "not " unless $x eq chr(300);
+    print "ok 14\n";
+
+    open F, "a" or die $!; # Not UTF
+    binmode(F, ":bytes");
+    $x = <F>;
+    chomp($x);
+    $chr = chr(196).chr(172);
+    if (ord('A') == 193) { $chr = chr(141).chr(83); } # EBCDIC
+    print "not " unless $x eq $chr;
+    print "ok 15\n";
+    close F;
+
+    open F, ">:utf8", 'a' or die $!;
+    binmode(F);  # we write a "\n" and then tell() - avoid CRLF issues.
+    binmode(F,":utf8"); # turn UTF-8-ness back on
+    print F $a;
+    my $y;
+    { my $x = tell(F);
+      { use bytes; $y = length($a);}
+      print "not " unless $x == $y;
+      print "ok 16\n";
+  }
+
+    { # Check byte length of $b
+	use bytes; my $y = length($b);
+	print "not " unless $y == 1;
+	print "ok 17\n";
+    }
+
+    print F $b,"\n"; # Don't upgrades $b
+
+    { # Check byte length of $b
+	use bytes; my $y = length($b);
+	print "not ($y) " unless $y == 1;
+	print "ok 18\n";
+    }
+
+    {
+	my $x = tell(F);
+	{ use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII
+	print "not ($x,$y) " unless $x == $y;
+	print "ok 19\n";
+    }
+
+    close F;
+
+    open F, "a" or die $!; # Not UTF
+    binmode(F, ":bytes");
+    $x = <F>;
+    chomp($x);
+    $chr = v196.172.194.130;
+    if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC
+    printf "not (%vd) ", $x unless $x eq $chr;
+    print "ok 20\n";
+
+    open F, "<:utf8", "a" or die $!;
+    $x = <F>;
+    chomp($x);
+    close F;
+    printf "not (%vd) ", $x unless $x eq chr(300).chr(130);
+    print "ok 21\n";
+
+    open F, ">", "a" or die $!;
+    if (${^OPEN} =~ /:utf8/) {
+        binmode(F, ":bytes:");
+    }
+
+    # Now let's make it suffer.
+    my $w;
+    {
+	use warnings 'utf8';
+	local $SIG{__WARN__} = sub { $w = $_[0] };
+	print F $a;
+	print "not " if ($@ || $w !~ /Wide character in print/i);
+    }
+    print "ok 22\n";
+}
+
+# Hm. Time to get more evil.
+open F, ">:utf8", "a" or die $!;
+print F $a;
+binmode(F, ":bytes");
+print F chr(130)."\n";
+close F;
+
+open F, "<", "a" or die $!;
+binmode(F, ":bytes");
+$x = <F>; chomp $x;
+$chr = v196.172.130;
+if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC
+print "not " unless $x eq $chr;
+print "ok 23\n";
+
+# Right.
+open F, ">:utf8", "a" or die $!;
+print F $a;
+close F;
+open F, ">>", "a" or die $!;
+print F chr(130)."\n";
+close F;
+
+open F, "<", "a" or die $!;
+$x = <F>; chomp $x;
+print "not " unless $x eq $chr;
+print "ok 24\n";
+
+# Now we have a deformed file.
+
+if (ord('A') == 193) {
+    print "ok 25 # Skip: EBCDIC\n"; # EBCDIC doesn't complain
+} else {
+    open F, "<:utf8", "a" or die $!;
+    $x = <F>; chomp $x;
+    local $SIG{__WARN__} = sub { print "ok 25\n" };
+    eval { sprintf "%vd\n", $x };
+}
+
+close F;
+unlink('a');
+
+open F, ">:utf8", "a";
+@a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000
+unshift @a, chr(0); # ... and a null byte in front just for fun
+print F @a;
+close F;
+
+my $c;
+
+# read() should work on characters, not bytes
+open F, "<:utf8", "a";
+$a = 0;
+for (@a) {
+    unless (($c = read(F, $b, 1) == 1)  &&
+            length($b)           == 1  &&
+            ord($b)              == ord($_) &&
+            tell(F)              == ($a += bytes::length($b))) {
+        print '# ord($_)           == ', ord($_), "\n";
+        print '# ord($b)           == ', ord($b), "\n";
+        print '# length($b)        == ', length($b), "\n";
+        print '# bytes::length($b) == ', bytes::length($b), "\n";
+        print '# tell(F)           == ', tell(F), "\n";
+        print '# $a                == ', $a, "\n";
+        print '# $c                == ', $c, "\n";
+        print "not ";
+        last;
+    }
+}
+close F;
+print "ok 26\n";
+
+{
+    # Check that warnings are on on I/O, and that they can be muffled.
+
+    local $SIG{__WARN__} = sub { $@ = shift };
+
+    undef $@;
+    open F, ">a";
+    binmode(F, ":bytes");
+    print F chr(0x100);
+    close(F);
+
+    print $@ =~ /Wide character in print/ ? "ok 27\n" : "not ok 27\n";
+
+    undef $@;
+    open F, ">:utf8", "a";
+    print F chr(0x100);
+    close(F);
+
+    print defined $@ ? "not ok 28\n" : "ok 28\n";
+
+    undef $@;
+    open F, ">a";
+    binmode(F, ":utf8");
+    print F chr(0x100);
+    close(F);
+
+    print defined $@ ? "not ok 29\n" : "ok 29\n";
+
+    no warnings 'utf8';
+
+    undef $@;
+    open F, ">a";
+    print F chr(0x100);
+    close(F);
+
+    print defined $@ ? "not ok 30\n" : "ok 30\n";
+
+    use warnings 'utf8';
+
+    undef $@;
+    open F, ">a";
+    binmode(F, ":bytes");
+    print F chr(0x100);
+    close(F);
+
+    print $@ =~ /Wide character in print/ ? "ok 31\n" : "not ok 31\n";
+}
+
+# sysread() and syswrite() tested in lib/open.t since Fnctl is used
+
+END {
+    1 while unlink "a";
+    1 while unlink "b";
+}
+
diff --git a/gnu/usr.bin/perl/t/japh/abigail.t b/gnu/usr.bin/perl/t/japh/abigail.t
new file mode 100644
index 00000000000..609294bac89
--- /dev/null
+++ b/gnu/usr.bin/perl/t/japh/abigail.t
@@ -0,0 +1,681 @@
+#!./perl -w
+
+#
+# Tests derived from Japhs.
+#
+# These test use obscure features of Perl, or surprising combinations
+# of features. The tests were added because in the past, they have
+# exposed several bugs in Perl.
+#
+# Some of these tests may actually (mis)use bugs or use undefined behaviour.
+# These tests are still useful - behavioural changes or bugfixes will be
+# noted, and a remark can be put in the documentation. (Don't forget to
+# disable the test!)
+#
+# Getting everything to run well on the myriad of platforms Perl runs on
+# is unfortunately not a trivial task.
+#
+# WARNING: these tests are obfuscated.  Do not get frustrated.
+# Ask Abigail <abigail@foad.org>, or use the Deparse or Concise
+# modules (the former parses Perl to Perl, the latter shows the
+# op syntax tree) like this:
+# ./perl -Ilib -MO=Deparse foo.pl
+# ./perl -Ilib -MO=Concise foo.pl
+#
+
+BEGIN {
+    if (ord("A") == 193) {
+	print "1..0 # Skip: EBCDIC\n"; # For now, until someone has time.
+	exit(0);
+    }
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require "./test.pl";
+    undef &skip;
+}
+
+skip_all "Unhappy on MacOS" if $^O eq 'MacOS';
+
+#
+# ./test.pl does real evilness by jumping to a label.
+# This function copies the skip from ./test, omitting the goto.
+#
+sub skip {
+    my $why  = shift;
+    my $n    = @_ ? shift : 1;
+    for (1..$n) {
+        my $test = curr_test;
+        print STDOUT "ok $test # skip: $why\n";
+        next_test;
+    }
+}
+
+
+#
+# ./test.pl doesn't give use 'notok', so we make it here.
+#
+sub notok {
+    my ($pass, $name, @mess) = @_;
+    _ok(!$pass, _where(), $name, @mess);
+}
+
+my $JaPH   = "Just another Perl Hacker";
+my $JaPh   = "Just another Perl hacker";
+my $JaPH_n = "Just another Perl Hacker\n";
+my $JaPh_n = "Just another Perl hacker\n";
+my $JaPH_s = "Just another Perl Hacker ";
+my $JaPh_s = "Just another Perl hacker ";
+my $JaPH_c = "Just another Perl Hacker,";
+my $JaPh_c = "Just another Perl hacker,";
+
+plan tests => 130;
+     
+{   
+    my $out  = sprintf "Just another Perl Hacker";
+    is ($out, $JaPH);
+}
+
+
+{   
+    my @primes     = (2,  3,  7, 13, 53, 101,  557, 1429);
+    my @composites = (4, 10, 25, 32, 75, 143, 1333, 1728);
+
+    my %primeness  = ((map {$_ => 1} @primes),
+                      (map {$_ => 0} @composites));
+
+    while (my ($num, $is_prime) = each %primeness) {
+        my $comment = "$num is " . ($is_prime ? "prime." : "composite.");
+
+        my $sub     = $is_prime ? "ok" : "notok";
+
+        &$sub (( 1  x $num) !~ /^1?$|^(11+?)\1+$/,       $comment);
+        &$sub (( 0  x $num) !~ m 0^\0?$|^(\0\0+?)\1+$0,  $comment);
+        &$sub (("m" x $num) !~ m m^\m?$|^(\m\m+?)\1+$mm, $comment);
+    }
+}
+
+
+{   # Some platforms use different quoting techniques.
+    # I do not have access to those platforms to test
+    # things out. So, we'll skip things....
+    if ($^O eq 'MSWin32' ||
+        $^O eq 'NetWare' ||
+        $^O eq 'VMS') {
+            skip "Your platform quotes differently.", 3;
+            last;
+    }
+
+    my $expected  =  $JaPH;
+       $expected  =~ s/ /\n/g;
+       $expected .= "\n";
+    is (runperl (switches => [qw /'-weprint<<EOT;' -eJust -eanother
+                                   -ePerl -eHacker -eEOT/],
+                 verbose  => 0),
+        $expected, "Multiple -e switches");
+
+    is (runperl (switches => [q  !'-wle$_=<<EOT;y/\n/ /;print;'!,
+                              qw ! -eJust -eanother -ePerl -eHacker -eEOT!],
+                 verbose  => 0),
+        $JaPH . " \n", "Multiple -e switches");
+
+    is (runperl (switches => [qw !-wl!],
+                 progs    => [qw !print qq-@{[ qw+ Just
+                                  another Perl Hacker +]}-!],
+                 verbose  => 0),
+        $JaPH_n, "Multiple -e switches");
+}
+
+{
+    if ($^O eq 'MSWin32' ||
+        $^O eq 'NetWare' ||
+        $^O eq 'VMS') {
+            skip "Your platform quotes differently.", 1;
+            last;
+    }
+    is (runperl (switches => [qw /-sweprint --/,
+                              "-_='Just another Perl Hacker'"],
+                 nolib    => 1,
+                 verbose  => 0),
+        $JaPH, 'setting $_ via -s');
+}
+
+{
+    my $datafile = "datatmp000";
+    1 while -f ++ $datafile;
+    END {unlink_all $datafile if $datafile}
+
+    open  MY_DATA, "> $datafile" or die "Failed to open $datafile: $!";
+    print MY_DATA  << "    --";
+        One
+        Two
+        Three
+        Four
+        Five
+        Six
+    --
+    close MY_DATA or die "Failed to close $datafile: $!\n";
+
+    my @progs;
+    my $key;
+    while (<DATA>) {
+        last if /^__END__$/;
+
+        if (/^#{7}(?:\s+(.*))?/) {
+            push @progs => {COMMENT  => $1 || '',
+                            CODE     => '',
+                            SKIP_OS  => [],
+                            ARGS     => [],
+                            SWITCHES => [],};
+            $key = 'CODE';
+            next;
+        }
+        elsif (/^(COMMENT|CODE|ARGS|SWITCHES|EXPECT|SKIP|SKIP_OS)
+                 (?::\s+(.*))?$/sx) {
+            $key = $1;
+            $progs [-1] {$key} = '' unless exists $progs [-1] {$key};
+            next unless defined $2;
+            $_ = $2;
+        }
+        elsif (/^$/) {
+            next;
+        }
+
+        if (ref ($progs [-1] {$key})) {
+            push @{$progs [-1] {$key}} => $_;
+        }
+        else {
+            $progs [-1] {$key} .=  $_;
+        }
+    }
+
+    foreach my $program (@progs) {
+        if (exists $program -> {SKIP}) {
+            chomp  $program -> {SKIP};
+            skip   $program -> {SKIP}, 1;
+            next;
+        }
+
+	chomp @{$program -> {SKIP_OS}};
+        if (@{$program -> {SKIP_OS}}) {
+            if (grep {$^O eq $_} @{$program -> {SKIP_OS}}) {
+                skip "Your OS uses different quoting.", 1;
+                next;
+            }
+        }
+
+        map {s/\$datafile/$datafile/} @{$program -> {ARGS}};
+        $program -> {EXPECT} = $JaPH unless exists $program -> {EXPECT};
+        $program -> {EXPECT} =~ s/\$JaPH_s\b/$JaPH_s/g;
+        $program -> {EXPECT} =~ s/\$JaPh_c\b/$JaPh_c/g;
+        $program -> {EXPECT} =~ s/\$JaPh\b/$JaPh/g;
+        chomp ($program -> {EXPECT}, @{$program -> {SWITCHES}},
+                                     @{$program -> {ARGS}});
+        fresh_perl_is ($program -> {CODE},
+                       $program -> {EXPECT},
+                      {switches => $program -> {SWITCHES},
+                       args     => $program -> {ARGS},
+                       verbose  =>  0},
+                       $program -> {COMMENT});
+    }
+}
+
+{
+    my $progfile = "progtmp000";
+    1 while -f ++ $progfile;
+    END {unlink_all $progfile if $progfile}
+
+    my @programs = (<< '    --', << '    --');
+#!./perl
+BEGIN{$|=$SIG{__WARN__}=sub{$_=$_[0];y-_- -;print/(.)"$/;seek _,-open(_ 
+,"+<$0"),2;truncate _,tell _;close _;exec$0}}//rekcaH_lreP_rehtona_tsuJ
+    --
+#!./perl
+BEGIN{$SIG{__WARN__}=sub{$_=pop;y-_- -;print/".*(.)"/;  
+truncate$0,-1+-s$0;exec$0;}}//rekcaH_lreP_rehtona_tsuJ
+    --
+    chomp @programs;
+
+    if ($^O eq 'VMS') {
+        # VMS needs extensions for files to be executable,
+        # but the Japhs above rely on $0 being exactly the
+        # filename of the program.
+        skip "VMS", 2 * @programs;
+        last
+    }
+
+    use Config;
+    unless (defined $Config {useperlio}) {
+        skip "Uuseperlio", 2 * @programs;
+        last
+    }
+
+    my $i = 1;
+    foreach my $program (@programs) {
+        open my $fh => "> $progfile" or die "Failed to open $progfile: $!\n";
+        print   $fh $program;
+        close   $fh or die "Failed to close $progfile: $!\n";
+
+        chmod 0755   => $progfile or die "Failed to chmod $progfile: $!\n";
+        my $command  = "./$progfile";
+           $command .= ' 2>&1' unless $^O eq 'MacOS';
+        if ( $^O eq 'qnx' ) {
+          skip "#!./perl not supported in QNX4";
+          skip "#!./perl not supported in QNX4";
+        } else {
+          my $output   = `$command`;
+
+          is ($output, $JaPH, "Self correcting code $i");
+
+                 $output   = `$command`;
+          is ($output, "",    "Self corrected code $i");
+        }
+        $i ++;
+    }
+}
+
+__END__
+#######  Funky loop 1.
+$_ = q ;4a75737420616e6f74686572205065726c204861636b65720as;;
+     for (s;s;s;s;s;s;s;s;s;s;s;s)
+         {s;(..)s?;qq qprint chr 0x$1 and \161 ssq;excess;}
+
+#######  Funky loop 2.
+$_ = q *4a75737420616e6f74686572205065726c204861636b65720a*;
+for ($*=******;$**=******;$**=******) {$**=*******s*..*qq}
+print chr 0x$& and q
+qq}*excess********}
+SKIP_OS: qnx
+
+#######  Funky loop 3.
+$_ = q *4a75737420616e6f74686572205065726c204861636b65720a*;
+for ($*=******;$**=******;$**=******) {$**=*******s*..*qq}
+print chr 0x$& and q
+qq}*excess********}
+SKIP_OS: qnx
+
+#######  Funky loop 4.
+$_ = q ?4a75737420616e6f74686572205065726c204861636b65720as?;??;
+for (??;(??)x??;??)
+    {??;s;(..)s?;qq ?print chr 0x$1 and \161 ss?;excess;??}
+SKIP: Abuses a fixed bug.
+
+#######  Funky loop 5.
+for (s??4a75737420616e6f74686572205065726c204861636b65720as?;??;??) 
+    {s?(..)s\??qq \?print chr 0x$1 and q ss\??excess}
+SKIP: Abuses a fixed bug.
+
+#######  Funky loop 6.
+$a = q 94a75737420616e6f74686572205065726c204861636b65720a9 and
+${qq$\x5F$} = q 97265646f9 and s g..g;
+qq e\x63\x68\x72\x20\x30\x78$&eggee;
+{eval if $a =~ s e..eqq qprint chr 0x$& and \x71\x20\x71\x71qeexcess}
+
+#######  Roman Dates.
+@r=reverse(M=>(0)x99=>CM=>(0)x399=>D=>(0)x99=>CD=>(
+0)x299=>C=>(0)x9=>XC=>(0)x39=>L=>(0)x9=>XL=>(0)x29=>X=>IX=>0=>0=>0=>V=>IV=>0=>0
+=>I=>$==-2449231+gm_julian_day+time);do{until($=<$#r){$_.=$r[$#r];$=-=$#r}for(;
+!$r[--$#r];){}}while$=;$,="\x20";print+$_=>September=>MCMXCIII=>=>=>=>=>=>=>=>
+SWITCHES
+-MTimes::JulianDay
+-l
+SKIP: Times::JulianDay not part of the main distribution.
+
+#######  Autoload 1.
+sub _'_{$_'_=~s/$a/$_/}map{$$_=$Z++}Y,a..z,A..X;*{($_::_=sprintf+q=%X==>"$A$Y".
+"$b$r$T$u")=~s~0~O~g;map+_::_,U=>T=>L=>$Z;$_::_}=*_;sub _{print+/.*::(.*)/s};;;
+*{chr($b*$e)}=*_'_;*__=*{chr(1<<$e)};                # Perl 5.6.0 broke this...
+_::_(r(e(k(c(a(H(__(l(r(e(P(__(r(e(h(t(o(n(a(__(t(us(J())))))))))))))))))))))))
+EXPECT: Just__another__Perl__Hacker
+
+#######  Autoload 2.
+$"=$,;*{;qq{@{[(A..Z)[qq[0020191411140003]=~m[..]g]]}}}=*_=sub{print/::(.*)/};
+$\=$/;q<Just another Perl Hacker>->();
+
+#######  Autoload 3.
+$"=$,;*{;qq{@{[(A..Z)[qq[0020191411140003]=~m[..]g]]}}}=*_;
+sub   _   {push         @_ => /::(.*)/s and goto &{ shift}}
+sub shift {print shift; @_              and goto &{+shift}}
+Hack ("Just", "Perl ", " ano", "er\n", "ther "); # YYYYMMDD
+
+#######  Autoload 4.
+$, = " "; sub AUTOLOAD {($AUTOLOAD =~ /::(.*)/) [0];}
+print+Just (), another (), Perl (), Hacker ();
+
+#######  Look ma! No letters!
+$@="\145\143\150\157\040\042\112\165\163\164\040\141\156\157\164".
+   "\150\145\162\040\120\145\162\154\040\110\141\143\153\145\162".
+   "\042\040\076\040\057\144\145\166\057\164\164\171";`$@`
+SKIP: Unix specific
+
+#######  sprintf fun 1.
+sub f{sprintf$_[0],$_[1],$_[2]}print f('%c%s',74,f('%c%s',117,f('%c%s',115,f(
+'%c%s',116,f('%c%s',32,f('%c%s',97,f('%c%s',0x6e,f('%c%s',111,f('%c%s',116,f(
+'%c%s',104,f('%c%s',0x65,f('%c%s',114,f('%c%s',32,f('%c%s',80,f('%c%s',101,f(
+'%c%s',114,f('%c%s',0x6c,f('%c%s',32,f('%c%s',0x48,f('%c%s',97,f('%c%s',99,f(
+'%c%s',107,f('%c%s',101,f('%c%s',114,f('%c%s',10,)))))))))))))))))))))))))
+
+#######  sprintf fun 2.
+sub f{sprintf'%c%s',$_[0],$_[1]}print f(74,f(117,f(115,f(116,f(32,f(97,
+f(110,f(111,f(116,f(104,f(0x65,f(114,f(32,f(80,f(101,f(114,f(0x6c,f(32,
+f(0x48,f(97,f(99,f(107,f(101,f(114,f(10,q ff)))))))))))))))))))))))))
+
+#######  Hanoi.
+%0=map{local$_=$_;reverse+chop,$_}ABC,ACB,BAC,BCA,CAB,CBA;$_=3 .AC;1while+
+s/(\d+)((.)(.))/($0=$1-1)?"$0$3$0{$2}1$2$0$0{$2}$4":"$3 => $4\n"/xeg;print
+EXPECT
+A => C
+A => B
+C => B
+A => C
+B => A
+B => C
+A => C
+
+#######  Funky -p 1
+}{$_=$.
+SWITCHES: -wlp
+ARGS:     $datafile
+EXPECT:   6
+
+#######  Funky -p 2
+}$_=$.;{
+SWITCHES: -wlp
+ARGS:     $datafile
+EXPECT:   6
+
+#######  Funky -p 3
+}{$_=$.}{
+SWITCHES: -wlp
+ARGS:     $datafile
+EXPECT:   6
+
+#######  Funky -p 4
+}{*_=*.}{
+SWITCHES: -wlp
+ARGS:     $datafile
+EXPECT:   6
+
+#######  Funky -p 5
+}for($.){print
+SWITCHES: -wln
+ARGS:     $datafile
+EXPECT:   6
+
+#######  Funky -p 6
+}{print$.
+SWITCHES: -wln
+ARGS:     $datafile
+EXPECT:   6
+
+#######  Funky -p 7
+}print$.;{
+SWITCHES: -wln
+ARGS:     $datafile
+EXPECT:   6
+
+#######  Abusing -M
+1
+SWITCHES
+-Mstrict='}); print "Just another Perl Hacker"; ({'
+-l
+SKIP_OS: VMS
+MSWin32
+NetWare
+
+#######  rand
+srand 123456;$-=rand$_--=>@[[$-,$_]=@[[$_,$-]for(reverse+1..(@[=split
+//=>"IGrACVGQ\x02GJCWVhP\x02PL\x02jNMP"));print+(map{$_^q^"^}@[),"\n"
+SKIP: Solaris specific.
+
+#######  print and __PACKAGE__
+package Just_another_Perl_Hacker; sub print {($_=$_[0])=~ s/_/ /g;
+                                      print } sub __PACKAGE__ { &
+                                      print (     __PACKAGE__)} &
+                                                  __PACKAGE__
+                                            (                )
+
+#######  Decorations.
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+/ / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / 
+% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %;
+BEGIN {% % = ($ _ = " " => print "Just another Perl Hacker\n")}
+
+#######  Tie 1
+sub J::FETCH{Just   }$_.='print+"@{[map';sub J::TIESCALAR{bless\my$J,J}
+sub A::FETCH{another}$_.='{tie my($x),$';sub A::TIESCALAR{bless\my$A,A}
+sub P::FETCH{Perl   }$_.='_;$x}qw/J A P';sub P::TIESCALAR{bless\my$P,P}
+sub H::FETCH{Hacker }$_.=' H/]}\n"';eval;sub H::TIESCALAR{bless\my$H,H}
+
+#######  Tie 2
+package Z;use overload'""'=>sub{$b++?Hacker:another};
+sub TIESCALAR{bless\my$y=>Z}sub FETCH{$a++?Perl:Just}
+$,=$";my$x=tie+my$y=>Z;print$y,$x,$y,$x,"\n";#Abigail
+EXPECT: $JaPH_s
+
+#######  Tie 3
+sub A::TIESCALAR{bless\my$x=>A};package B;@q[0..3]=qw/Hacker Perl
+another Just/;use overload'""'=>sub{pop @q};sub A::FETCH{bless\my
+$y=>B}; tie my $shoe => qq 'A';print "$shoe $shoe $shoe $shoe\n";
+
+#######  Tie 4
+sub A::TIESCALAR{bless\my$x=>'A'};package B;@q=qw/Hacker Perl
+another Just/;use overload'""',sub{pop @q};sub A::FETCH{bless
+\my $y=>B};tie my$shoe=>'A';print"$shoe $shoe $shoe $shoe\n";
+
+#######  Tie 5
+tie $" => A; $, = " "; $\ = "\n"; @a = ("") x 2; print map {"@a"} 1 .. 4;
+sub A::TIESCALAR {bless \my $A => A} #  Yet Another silly JAPH by Abigail
+sub A::FETCH     {@q = qw /Just Another Perl Hacker/ unless @q; shift @q}
+SKIP: Pending a bug fix.
+
+#######  Prototype fun 1
+sub camel (^#87=i@J&&&#]u'^^s]#'#={123{#}7890t[0.9]9@+*`"'***}A&&&}n2o}00}t324i;
+h[{e **###{r{+P={**{e^^^#'#i@{r'^=^{l+{#}H***i[0.9]&@a5`"':&^;&^,*&^$43##@@####;
+c}^^^&&&k}&&&}#=e*****[]}'r####'`=437*{#};::'1[0.9]2@43`"'*#==[[.{{],,,1278@#@);
+print+((($llama=prototype'camel')=~y|+{#}$=^*&[0-9]i@:;`"',.| |d)&&$llama."\n");
+SKIP: Abuses a fixed bug.
+
+#######  Prototype fun 2
+print prototype sub "Just another Perl Hacker" {};
+
+#######  Prototype fun 3
+sub _ "Just another Perl Hacker"; print prototype \&_
+
+#######  Split 1
+               split // => '"';
+${"@_"} = "/"; split // => eval join "+" => 1 .. 7;
+*{"@_"} = sub {foreach (sort keys %_)  {print "$_ $_{$_} "}};
+%{"@_"} = %_ = (Just => another => Perl => Hacker); &{%{%_}};
+EXPECT: $JaPH_s
+
+#######  Split 2
+$" = "/"; split // => eval join "+" => 1 .. 7;
+*{"@_"} = sub {foreach (sort keys %_) {print "$_ $_{$_} "}};
+%_ = (Just => another => Perl => Hacker); &{%_};
+EXPECT: $JaPH_s
+
+#######  Split 3
+$" = "/"; split $, => eval join "+" => 1 .. 7;
+*{"@_"} = sub  {foreach (sort keys %_) {print "$_ $_{$_} "}};
+%{"@_"} = %_ = (Just => another => Perl => Hacker); &{%{%_}};
+EXPECT: $JaPH_s
+
+#######  Here documents 1
+$_ = "\x3C\x3C\x45\x4F\x54"; s/<<EOT/<<EOT/e; print;
+Just another Perl Hacker
+EOT
+
+#######  Here documents 2
+$_ = "\x3C\x3C\x45\x4F\x54";
+print if s/<<EOT/<<EOT/e;
+Just another Perl Hacker
+EOT
+
+#######  Here documents 3
+$_ = "\x3C\x3C\x45\x4F\x54" and s/<<EOT/<<EOT/e and print;
+Just another Perl Hacker
+EOT
+
+#######  Here documents 4
+$_ = "\x3C\x3C\x45\x4F\x54\n" and s/<<EOT/<<EOT/ee and print;
+"Just another Perl Hacker"
+EOT
+
+#######  Self modifying code 1
+$_ = "goto F.print chop;\n=rekcaH lreP rehtona tsuJ";F1:eval
+SWITCHES: -w
+
+#######  Overloaded constants 1
+BEGIN {$^H {q} = sub {pop and pop and print pop}; $^H = 2**4.2**12}
+"Just "; "another "; "Perl "; "Hacker";
+SKIP_OS: qnx
+
+#######  Overloaded constants 2
+BEGIN {$^H {q} = sub {$_ [1] =~ y/S-ZA-IK-O/q-tc-fe-m/d; $_ [1]}; $^H = 0x28100}
+print "Just another PYTHON hacker\n";
+EXPECT: $JaPh
+
+#######  Overloaded constants 3
+BEGIN {$^H {join "" => ("a" .. "z") [8, 13, 19, 4, 6, 4, 17]} = sub
+           {["", "Just ", "another ", "Perl ", "Hacker\n"] -> [shift]};
+       $^H = hex join "" => reverse map {int ($_ / 2)} 0 .. 4}
+print 1, 2, 3, 4;
+
+#######  Overloaded constants 4
+BEGIN {$^H {join "" => ("a" .. "z") [8, 13, 19, 4, 6, 4, 17]} = sub
+           {["", "Just ", "another ", "Perl ", "Hacker"] -> [shift]};
+       $^H = hex join "" => reverse map {int ($_ / 2)} 0 .. 4}
+print 1, 2, 3, 4, "\n";
+
+#######  Overloaded constants 5
+BEGIN {my $x = "Knuth heals rare project\n";
+       $^H {integer} = sub {my $y = shift; $_ = substr $x => $y & 0x1F, 1;
+       $y > 32 ? uc : lc}; $^H = hex join "" => 2, 1, 1, 0, 0}
+print 52,2,10,23,16,8,1,19,3,6,15,12,5,49,21,14,9,11,36,13,22,32,7,18,24;
+
+#######  v-strings 1
+print v74.117.115.116.32;
+print v97.110.111.116.104.101.114.32;
+print v80.101.114.108.32;
+print v72.97.99.107.101.114.10;
+
+#######  v-strings 2
+print 74.117.115.116.32;
+print 97.110.111.116.104.101.114.32;
+print 80.101.114.108.32;
+print 72.97.99.107.101.114.10;
+
+#######  v-strings 3
+print v74.117.115.116.32, v97.110.111.116.104.101.114.32,
+      v80.101.114.108.32, v72.97.99.107.101.114.10;
+
+#######  v-strings 4
+print 74.117.115.116.32, 97.110.111.116.104.101.114.32,
+      80.101.114.108.32, 72.97.99.107.101.114.10;
+
+#######  v-strings 5
+print v74.117.115.116.32.97.110.111.116.104.101.114.
+      v32.80.101.114.108.32.72.97.99.107.101.114.10;
+
+#######  v-strings 6
+print 74.117.115.116.32.97.110.111.116.104.101.114.
+      32.80.101.114.108.32.72.97.99.107.101.114.10;
+
+#######  Symbolic references.
+map{${+chr}=chr}map{$_=>$_^ord$"}$=+$]..3*$=/2;        
+print "$J$u$s$t $a$n$o$t$h$e$r $P$e$r$l $H$a$c$k$e$r\n";
+
+#######  $; fun
+$;                                   # A lone dollar?
+=$";                                 # Pod?
+$;                                   # The return of the lone dollar?
+{Just=>another=>Perl=>Hacker=>}      # Bare block?
+=$/;                                 # More pod?
+print%;                              # No right operand for %?
+
+#######  @; fun
+@;=split//=>"Joel, Preach sartre knuth\n";$;=chr 65;%;=map{$;++=>$_}
+0,22,13,16,5,14,21,1,23,11,2,7,12,6,8,15,3,19,24,14,10,20,18,17,4,25
+;print@;[@;{A..Z}];
+EXPECT: $JaPh_c
+
+#######  %; fun
+$;=$";$;{Just=>another=>Perl=>Hacker=>}=$/;print%;
+
+####### &func;
+$_ = "\112\165\163\1648\141\156\157\164\150\145\1628\120\145"
+   . "\162\1548\110\141\143\153\145\162\0128\177"  and &japh;
+sub japh {print "@_" and return if pop; split /\d/ and &japh}
+
+####### magic goto.
+sub _ {$_ = shift and y/b-yB-Y/a-yB-Y/                xor      !@ _?
+       exit print                                                  :
+            print and push @_ => shift and goto &{(caller (0)) [3]}}
+            split // => "KsvQtbuf fbsodpmu\ni flsI "  xor       & _
+
+####### $: fun 1
+:$:=~s:$":Just$&another$&:;$:=~s:
+:Perl$"Hacker$&:;chop$:;print$:#:
+
+####### $: fun 2
+ :;$:=~s:
+-:;another Perl Hacker
+ :;chop
+$:;$:=~y
+ :;::d;print+Just.
+$:;
+
+####### $: fun 3
+ :;$:=~s:
+-:;another Perl Hacker
+ :;chop
+$:;$:=~y:;::d;print+Just.$:
+
+####### $!
+s[$,][join$,,(split$,,($!=85))[(q[0006143730380126152532042307].
+q[41342211132019313505])=~m[..]g]]e and y[yIbp][HJkP] and print;
+SKIP: Platform dependent.
+
+####### die 1
+eval {die ["Just another Perl Hacker"]}; print ${$@}[$#{@${@}}]
+
+####### die 2
+eval {die ["Just another Perl Hacker\n"]}; print ${$@}[$#{@${@}}]
+
+####### die 3
+eval {die ["Just another Perl Hacker"]}; print ${${@}}[$#{@{${@}}}]
+
+####### die 4
+eval {die ["Just another Perl Hacker\n"]}; print ${${@}}[$#{@{${@}}}]
+
+####### die 5
+eval {die [[qq [Just another Perl Hacker]]]};; print
+${${${@}}[$#{@{${@}}}]}[$#{${@{${@}}}[$#{@{${@}}}]}]
+
+####### Closure returning itself.
+$_ = "\nrekcaH lreP rehtona tsuJ"; my $chop; $chop = sub {print chop; $chop};
+$chop -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> ()
+-> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> ()
+
+####### Special blocks 1
+BEGIN {print "Just "   }
+CHECK {print "another "}
+INIT  {print "Perl "   }
+END   {print "Hacker\n"}
+
+####### Special blocks 2
+END   {print "Hacker\n"}
+INIT  {print "Perl "   }
+CHECK {print "another "}
+BEGIN {print "Just "   }
+
+####### Recursive regex.
+   my $qr =  qr/^.+?(;).+?\1|;Just another Perl Hacker;|;.+$/;
+      $qr =~  s/$qr//g;
+print $qr, "\n";
+
+####### use lib 'coderef'
+use   lib sub {($\) = split /\./ => pop; print $"};
+eval "use Just" || eval "use another" || eval "use Perl" || eval "use Hacker";
+EXPECT
+ Just another Perl Hacker
diff --git a/gnu/usr.bin/perl/t/lib/1_compile.t b/gnu/usr.bin/perl/t/lib/1_compile.t
new file mode 100644
index 00000000000..45631dd5b8d
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/1_compile.t
@@ -0,0 +1,81 @@
+#!./perl
+
+# Modules should have their own tests.  For historical reasons, some
+# do not.  This does basic compile tests on modules that have no tests
+# of their own.
+
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+}
+
+use strict;
+use warnings;
+use File::Spec::Functions;
+
+# Okay, this is the list.
+
+my @Core_Modules = grep /\S/, <DATA>;
+chomp @Core_Modules;
+
+if (eval { require Socket }) {
+  push @Core_Modules, qw(Net::Domain);
+  # Two Net:: modules need the Convert::EBCDIC if in EBDCIC.
+  if (ord("A") != 193 || eval { require Convert::EBCDIC }) {
+      push @Core_Modules, qw(Net::Cmd Net::POP3);
+  }
+}
+
+@Core_Modules = sort @Core_Modules;
+
+print "1..".(1+@Core_Modules)."\n";
+
+my $message
+  = "ok 1 - All modules should have tests # TODO Make Schwern Poorer\n";
+if (@Core_Modules) {
+  print "not $message";
+} else {
+  print $message;
+}
+
+my $test_num = 2;
+
+foreach my $module (@Core_Modules) {
+    my $todo = '';
+    $todo = "# TODO $module needs porting on $^O" if $module eq 'ByteLoader' && $^O eq 'VMS';
+    print "# $module compile failed\nnot " unless compile_module($module);
+    print "ok $test_num $todo\n";
+    $test_num++;
+}
+
+# We do this as a separate process else we'll blow the hell
+# out of our namespace.
+sub compile_module {
+    my ($module) = $_[0];
+
+    my $compmod = catfile(curdir(), 'lib', 'compmod.pl');
+    my $lib     = '-I' . catdir(updir(), 'lib');
+
+    my $out = scalar `$^X $lib $compmod $module`;
+    print "# $out";
+    return $out =~ /^ok/;
+}
+
+# These modules have no tests of their own.
+# Keep up to date with
+# http://www.pobox.com/~schwern/cgi-bin/perl-qa-wiki.cgi?UntestedModules
+# and vice-versa.  The list should only shrink.
+__DATA__
+B::C
+B::CC
+B::Stackobj
+ByteLoader
+CPAN
+CPAN::FirstTime
+DynaLoader
+ExtUtils::MM_NW5
+ExtUtils::Install
+ExtUtils::Liblist
+ExtUtils::Mksymlists
+Pod::Plainer
+Test::Harness::Iterator
diff --git a/gnu/usr.bin/perl/t/lib/Filter/Simple/ExportTest.pm b/gnu/usr.bin/perl/t/lib/Filter/Simple/ExportTest.pm
new file mode 100644
index 00000000000..d6da62921b7
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Filter/Simple/ExportTest.pm
@@ -0,0 +1,12 @@
+package ExportTest;
+
+use Filter::Simple;
+use base Exporter;
+
+@EXPORT_OK = qw(ok);
+
+FILTER { s/not// };
+
+sub ok { print "ok @_\n" }
+
+1;
diff --git a/gnu/usr.bin/perl/t/lib/Filter/Simple/FilterOnlyTest.pm b/gnu/usr.bin/perl/t/lib/Filter/Simple/FilterOnlyTest.pm
new file mode 100644
index 00000000000..856e79de6ac
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Filter/Simple/FilterOnlyTest.pm
@@ -0,0 +1,11 @@
+package FilterOnlyTest;
+
+use Filter::Simple;
+
+FILTER_ONLY
+	string => sub {
+		my $class = shift;
+		while (my($pat, $str) = splice @_, 0, 2) {
+			s/$pat/$str/g;
+		}
+	};
diff --git a/gnu/usr.bin/perl/t/lib/Filter/Simple/FilterTest.pm b/gnu/usr.bin/perl/t/lib/Filter/Simple/FilterTest.pm
new file mode 100644
index 00000000000..c49e280d2c5
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Filter/Simple/FilterTest.pm
@@ -0,0 +1,12 @@
+package FilterTest;
+
+use Filter::Simple;
+
+FILTER {
+	my $class = shift;
+	while (my($pat, $str) = splice @_, 0, 2) {
+		s/$pat/$str/g;
+	}
+};
+
+1;
diff --git a/gnu/usr.bin/perl/t/lib/Filter/Simple/ImportTest.pm b/gnu/usr.bin/perl/t/lib/Filter/Simple/ImportTest.pm
new file mode 100644
index 00000000000..6646a36a685
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Filter/Simple/ImportTest.pm
@@ -0,0 +1,19 @@
+package ImportTest;
+
+use base 'Exporter';
+@EXPORT = qw(say);
+
+sub say { print @_ }
+
+use Filter::Simple;
+
+sub import {
+	my $class = shift;
+	print "ok $_\n" foreach @_;
+	__PACKAGE__->export_to_level(1,$class);
+}
+
+FILTER { s/not // };
+
+
+1;
diff --git a/gnu/usr.bin/perl/t/lib/MakeMaker/Test/Utils.pm b/gnu/usr.bin/perl/t/lib/MakeMaker/Test/Utils.pm
new file mode 100644
index 00000000000..9260faf3433
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/MakeMaker/Test/Utils.pm
@@ -0,0 +1,241 @@
+package MakeMaker::Test::Utils;
+
+use File::Spec;
+use strict;
+use Config;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+require Exporter;
+@ISA = qw(Exporter);
+
+$VERSION = 0.02;
+
+@EXPORT = qw(which_perl perl_lib makefile_name makefile_backup
+             make make_run make_macro calibrate_mtime
+            );
+
+my $Is_VMS   = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+
+=head1 NAME
+
+MakeMaker::Test::Utils - Utility routines for testing MakeMaker
+
+=head1 SYNOPSIS
+
+  use MakeMaker::Test::Utils;
+
+  my $perl     = which_perl;
+  perl_lib;
+
+  my $makefile      = makefile_name;
+  my $makefile_back = makefile_backup;
+
+  my $make          = make;
+  my $make_run      = make_run;
+  make_macro($make, $targ, %macros);
+
+  my $mtime         = calibrate_mtime;
+
+=head1 DESCRIPTION
+
+A consolidation of little utility functions used through out the
+MakeMaker test suite.
+
+=head2 Functions
+
+The following are exported by default.
+
+=over 4
+
+=item B<which_perl>
+
+  my $perl = which_perl;
+
+Returns a path to perl which is safe to use in a command line, no
+matter where you chdir to.
+
+=cut
+
+sub which_perl {
+    my $perl = $^X;
+    $perl ||= 'perl';
+
+    # VMS should have 'perl' aliased properly
+    return $perl if $Is_VMS;
+
+    $perl .= $Config{exe_ext} unless $perl =~ m/$Config{exe_ext}$/i;
+
+    my $perlpath = File::Spec->rel2abs( $perl );
+    unless( $Is_MacOS || -x $perlpath ) {
+        # $^X was probably 'perl'
+
+        # When building in the core, *don't* go off and find
+        # another perl
+        die "Can't find a perl to use (\$^X=$^X), (\$perlpath=$perlpath)" 
+          if $ENV{PERL_CORE};
+
+        foreach my $path (File::Spec->path) {
+            $perlpath = File::Spec->catfile($path, $perl);
+            last if -x $perlpath;
+        }
+    }
+
+    return $perlpath;
+}
+
+=item B<perl_lib>
+
+  perl_lib;
+
+Sets up environment variables so perl can find its libraries.
+
+=cut
+
+my $old5lib = $ENV{PERL5LIB};
+my $had5lib = exists $ENV{PERL5LIB};
+sub perl_lib {
+                               # perl-src/t/
+    my $lib =  $ENV{PERL_CORE} ? qq{../lib}
+                               # ExtUtils-MakeMaker/t/
+                               : qq{../blib/lib};
+    $lib = File::Spec->rel2abs($lib);
+    my @libs = ($lib);
+    push @libs, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
+    $ENV{PERL5LIB} = join($Config{path_sep}, @libs);
+    unshift @INC, $lib;
+}
+
+END { 
+    if( $had5lib ) {
+        $ENV{PERL5LIB} = $old5lib;
+    }
+    else {
+        delete $ENV{PERL5LIB};
+    }
+}
+
+
+=item B<makefile_name>
+
+  my $makefile = makefile_name;
+
+MakeMaker doesn't always generate 'Makefile'.  It returns what it
+should generate.
+
+=cut
+
+sub makefile_name {
+    return $Is_VMS ? 'Descrip.MMS' : 'Makefile';
+}   
+
+=item B<makefile_backup>
+
+  my $makefile_old = makefile_backup;
+
+Returns the name MakeMaker will use for a backup of the current
+Makefile.
+
+=cut
+
+sub makefile_backup {
+    my $makefile = makefile_name;
+    return $Is_VMS ? $makefile : "$makefile.old";
+}
+
+=item B<make>
+
+  my $make = make;
+
+Returns a good guess at the make to run.
+
+=cut
+
+sub make {
+    my $make = $Config{make};
+    $make = $ENV{MAKE} if exists $ENV{MAKE};
+
+    return $make;
+}
+
+=item B<make_run>
+
+  my $make_run = make_run;
+
+Returns the make to run as with make() plus any necessary switches.
+
+=cut
+
+sub make_run {
+    my $make = make;
+    $make .= ' -nologo' if $make eq 'nmake';
+
+    return $make;
+}
+
+=item B<make_macro>
+
+    my $make_cmd = make_macro($make, $target, %macros);
+
+Returns the command necessary to run $make on the given $target using
+the given %macros.
+
+  my $make_test_verbose = make_macro(make_run(), 'test', 
+                                     TEST_VERBOSE => 1);
+
+This is important because VMS's make utilities have a completely
+different calling convention than Unix or Windows.
+
+%macros is actually a list of tuples, so the order will be preserved.
+
+=cut
+
+sub make_macro {
+    my($make, $target) = (shift, shift);
+
+    my $is_mms = $make =~ /^MM(K|S)/i;
+
+    my $cmd = $make;
+    my $macros = '';
+    while( my($key,$val) = splice(@_, 0, 2) ) {
+        if( $is_mms ) {
+            $macros .= qq{/macro="$key=$val"};
+        }
+        else {
+            $macros .= qq{ $key=$val};
+        }
+    }
+
+    return $is_mms ? "$make$macros $target" : "$make $target $macros";
+}
+
+=item B<calibrate_mtime>
+
+  my $mtime = calibrate_mtime;
+
+When building on NFS, file modification times can often lose touch
+with reality.  This returns the mtime of a file which has just been
+touched.
+
+=cut
+
+sub calibrate_mtime {
+    open(FILE, ">calibrate_mtime.tmp") || die $!;
+    print FILE "foo";
+    close FILE;
+    my($mtime) = (stat('calibrate_mtime.tmp'))[9];
+    unlink 'calibrate_mtime.tmp';
+    return $mtime;
+}
+
+=back
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern@pobox.com>
+
+=cut
+
+1;
diff --git a/gnu/usr.bin/perl/t/lib/Math/BigFloat/Subclass.pm b/gnu/usr.bin/perl/t/lib/Math/BigFloat/Subclass.pm
new file mode 100644
index 00000000000..82ad7e6c833
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Math/BigFloat/Subclass.pm
@@ -0,0 +1,44 @@
+#!/usr/bin/perl -w
+
+package Math::BigFloat::Subclass;
+
+require 5.005_02;
+use strict;
+
+use Exporter;
+use Math::BigFloat(1.27);
+use vars qw($VERSION @ISA $PACKAGE
+            $accuracy $precision $round_mode $div_scale);
+
+@ISA = qw(Exporter Math::BigFloat);
+
+$VERSION = 0.03;
+
+use overload; 		# inherit overload from BigInt
+
+# Globals
+$accuracy = $precision = undef;
+$round_mode = 'even';
+$div_scale = 40;
+
+sub new
+{
+        my $proto  = shift;
+        my $class  = ref($proto) || $proto;
+
+        my $value       = shift;
+	my $a = $accuracy; $a = $_[0] if defined $_[0];
+	my $p = $precision; $p = $_[1] if defined $_[1];
+        # Store the floating point value
+        my $self = Math::BigFloat->new($value,$a,$p,$round_mode);
+        bless $self, $class;
+        $self->{'_custom'} = 1; # make sure this never goes away
+        return $self;
+}
+
+BEGIN
+  {
+  *objectify = \&Math::BigInt::objectify;
+  }
+
+1;
diff --git a/gnu/usr.bin/perl/t/lib/Math/BigInt/BareCalc.pm b/gnu/usr.bin/perl/t/lib/Math/BigInt/BareCalc.pm
new file mode 100644
index 00000000000..797957f7481
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Math/BigInt/BareCalc.pm
@@ -0,0 +1,36 @@
+package Math::BigInt::BareCalc;
+
+use 5.005;
+use strict;
+# use warnings;	# dont use warnings for older Perls
+
+require Exporter;
+use vars qw/@ISA $VERSION/;
+@ISA = qw(Exporter);
+
+$VERSION = '0.02';
+
+# Package to to test Bigint's simulation of Calc
+
+# uses Calc, but only features the strictly necc. methods.
+
+use Math::BigInt::Calc '0.29';
+
+BEGIN
+  {
+  no strict 'refs';
+  foreach (qw/	base_len new zero one two copy str num add sub mul div inc dec
+		acmp len digit zeros
+		is_zero is_one is_odd is_even is_one check
+		to_small to_large
+		/)
+    {
+    my $name  = "Math::BigInt::Calc::_$_";
+    *{"Math::BigInt::BareCalc::_$_"} = \&$name;
+    }
+  }
+
+# catch and throw away
+sub import { }
+
+1;
diff --git a/gnu/usr.bin/perl/t/lib/Math/BigInt/Subclass.pm b/gnu/usr.bin/perl/t/lib/Math/BigInt/Subclass.pm
new file mode 100644
index 00000000000..688ad237698
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Math/BigInt/Subclass.pm
@@ -0,0 +1,81 @@
+#!/usr/bin/perl -w
+
+package Math::BigInt::Subclass;
+
+require 5.005_02;
+use strict;
+
+use Exporter;
+use Math::BigInt(1.56);
+use vars qw($VERSION @ISA $PACKAGE @EXPORT_OK
+            $accuracy $precision $round_mode $div_scale);
+
+@ISA = qw(Exporter Math::BigInt);
+@EXPORT_OK = qw(bgcd objectify);
+
+$VERSION = 0.03;
+
+use overload;	# inherit overload from BigInt
+
+# Globals
+$accuracy = $precision = undef;
+$round_mode = 'even';
+$div_scale = 40;
+
+sub new
+{
+        my $proto  = shift;
+        my $class  = ref($proto) || $proto;
+
+        my $value       = shift;
+	my $a = $accuracy; $a = $_[0] if defined $_[0];
+	my $p = $precision; $p = $_[1] if defined $_[1];
+        my $self = Math::BigInt->new($value,$a,$p,$round_mode);
+	bless $self,$class;
+        $self->{'_custom'} = 1; # make sure this never goes away
+        return $self;
+}
+
+sub bgcd
+  {
+  Math::BigInt::bgcd(@_);
+  }
+
+sub blcm
+  {
+  Math::BigInt::blcm(@_);
+  }
+
+BEGIN
+  {
+  *objectify = \&Math::BigInt::objectify;
+
+  # these are called by AUTOLOAD from BigFloat, so we need at least these.
+  # We cheat, of course..
+  *bneg = \&Math::BigInt::bneg;
+  *babs = \&Math::BigInt::babs;
+  *bnan = \&Math::BigInt::bnan;
+  *binf = \&Math::BigInt::binf;
+  *bzero = \&Math::BigInt::bzero;
+  *bone = \&Math::BigInt::bone;
+  }
+
+sub import
+  {
+  my $self = shift;
+
+  my @a; my $t = 0;
+  foreach (@_)
+    {
+    $t = 0, next if $t == 1;
+    if ($_ eq 'lib')
+      {
+      $t = 1; next;
+      }
+    push @a,$_;
+    }
+  $self->SUPER::import(@a);			# need it for subclasses
+  $self->export_to_level(1,$self,@a);		# need this ?
+  }
+
+1;
diff --git a/gnu/usr.bin/perl/t/lib/Math/BigRat/Test.pm b/gnu/usr.bin/perl/t/lib/Math/BigRat/Test.pm
new file mode 100644
index 00000000000..80be068a27a
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Math/BigRat/Test.pm
@@ -0,0 +1,81 @@
+#!/usr/bin/perl -w
+
+package Math::BigRat::Test;
+
+require 5.005_02;
+use strict;
+
+use Exporter;
+use Math::BigRat;
+use Math::BigFloat;
+use vars qw($VERSION @ISA $PACKAGE
+            $accuracy $precision $round_mode $div_scale);
+
+@ISA = qw(Exporter Math::BigRat);
+$VERSION = 0.03;
+
+use overload; 		# inherit overload from BigRat
+
+# Globals
+$accuracy = $precision = undef;
+$round_mode = 'even';
+$div_scale = 40;
+
+my $class = 'Math::BigRat::Test';
+
+#ub new
+#{
+#        my $proto  = shift;
+#        my $class  = ref($proto) || $proto;
+#
+#        my $value       = shift;
+#	my $a = $accuracy; $a = $_[0] if defined $_[0];
+#	my $p = $precision; $p = $_[1] if defined $_[1];
+#        # Store the floating point value
+#        my $self = Math::BigFloat->new($value,$a,$p,$round_mode);
+#        bless $self, $class;
+#        $self->{'_custom'} = 1; # make sure this never goes away
+#        return $self;
+#}
+
+sub bstr
+  {
+  # calculate a BigFloat compatible string output
+  my ($x) = @_;
+
+  $x = $class->new($x) unless ref $x;
+
+  if ($x->{sign} !~ /^[+-]$/)           # inf, NaN etc
+    {
+    my $s = $x->{sign}; $s =~ s/^\+//;  # +inf => inf
+    return $s;
+    }
+
+  my $s = ''; $s = $x->{sign} if $x->{sign} ne '+';     # +3 vs 3
+
+  return $s.$x->{_n} if $x->{_d}->is_one(); 
+  my $output = Math::BigFloat->new($x->{_n})->bdiv($x->{_d});
+  return $s.$output->bstr();
+  }
+
+sub bsstr
+  {
+  # calculate a BigFloat compatible string output
+  my ($x) = @_;
+
+  $x = $class->new($x) unless ref $x;
+
+  if ($x->{sign} !~ /^[+-]$/)           # inf, NaN etc
+    {
+    my $s = $x->{sign}; $s =~ s/^\+//;  # +inf => inf
+    return $s;
+    }
+
+  my $s = ''; $s = $x->{sign} if $x->{sign} ne '+';     # +3 vs 3
+
+  return $s.$x->{_n}->bsstr() if $x->{_d}->is_one(); 
+  my $output = Math::BigFloat->new($x->{_n})->bdiv($x->{_d});
+  return $s.$output->bsstr();
+  }
+
+1;
diff --git a/gnu/usr.bin/perl/t/lib/Test/Simple/Catch.pm b/gnu/usr.bin/perl/t/lib/Test/Simple/Catch.pm
new file mode 100644
index 00000000000..e1ccd7ce454
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Test/Simple/Catch.pm
@@ -0,0 +1,32 @@
+# For testing Test::Simple;
+package Test::Simple::Catch;
+
+use Symbol;
+my($out_fh, $err_fh) = (gensym, gensym);
+my $out = tie *$out_fh, __PACKAGE__;
+my $err = tie *$err_fh, __PACKAGE__;
+
+use Test::Builder;
+my $t = Test::Builder->new;
+$t->output($out_fh);
+$t->failure_output($err_fh);
+$t->todo_output($err_fh);
+
+sub caught { return($out, $err) }
+
+sub PRINT  {
+    my $self = shift;
+    $$self .= join '', @_;
+}
+
+sub TIEHANDLE {
+    my $class = shift;
+    my $self = '';
+    return bless \$self, $class;
+}
+sub READ {}
+sub READLINE {}
+sub GETC {}
+sub FILENO {}
+
+1;
diff --git a/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/death.plx b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/death.plx
new file mode 100644
index 00000000000..ef4ba8c1880
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/death.plx
@@ -0,0 +1,13 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+close STDERR;
+
+ok(1);
+ok(1);
+ok(1);
+die "Knife?";
diff --git a/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/death_in_eval.plx b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/death_in_eval.plx
new file mode 100644
index 00000000000..269bffa8025
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/death_in_eval.plx
@@ -0,0 +1,22 @@
+require Test::Simple;
+use Carp;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+ok(1);
+ok(1);
+ok(1);
+eval {
+        die "Foo";
+};
+ok(1);
+eval "die 'Bar'";
+ok(1);
+
+eval {
+        croak "Moo";
+};
diff --git a/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/extras.plx b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/extras.plx
new file mode 100644
index 00000000000..c9c89520aa3
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/extras.plx
@@ -0,0 +1,16 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+
+ok(1);
+ok(1);
+ok(1);
+ok(1);
+ok(0);
+ok(1);
+ok(0);
diff --git a/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/five_fail.plx b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/five_fail.plx
new file mode 100644
index 00000000000..c058e1f8f01
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/five_fail.plx
@@ -0,0 +1,13 @@
+require Test::Simple;
+
+use lib 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+ok(0);
+ok(0);
+ok('');
+ok(0);
+ok(0);
diff --git a/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/last_minute_death.plx b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/last_minute_death.plx
new file mode 100644
index 00000000000..ef86a63c51e
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/last_minute_death.plx
@@ -0,0 +1,16 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+close STDERR;
+
+ok(1);
+ok(1);
+ok(1);
+ok(1);
+ok(1);
+
+die "Almost there...";
diff --git a/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/one_fail.plx b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/one_fail.plx
new file mode 100644
index 00000000000..99c720250d2
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/one_fail.plx
@@ -0,0 +1,14 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+
+ok(1);
+ok(2);
+ok(0);
+ok(1);
+ok(2);
diff --git a/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/require.plx b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/require.plx
new file mode 100644
index 00000000000..1a06690d9dc
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/require.plx
@@ -0,0 +1 @@
+require Test::Simple;
diff --git a/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/success.plx b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/success.plx
new file mode 100644
index 00000000000..585d6c3d790
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/success.plx
@@ -0,0 +1,13 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+ok(1);
+ok(5, 'yep');
+ok(3, 'beer');
+ok("wibble", "wibble");
+ok(1);
diff --git a/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/too_few.plx b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/too_few.plx
new file mode 100644
index 00000000000..95af8e903b6
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/too_few.plx
@@ -0,0 +1,11 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+
+ok(1);
+ok(0);
diff --git a/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/two_fail.plx b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/two_fail.plx
new file mode 100644
index 00000000000..e3d92296af9
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/Test/Simple/sample_tests/two_fail.plx
@@ -0,0 +1,14 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+
+ok(0);
+ok(1);
+ok(1);
+ok(0);
+ok(1);
diff --git a/gnu/usr.bin/perl/t/lib/TieOut.pm b/gnu/usr.bin/perl/t/lib/TieOut.pm
new file mode 100644
index 00000000000..072e8fdef6a
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/TieOut.pm
@@ -0,0 +1,23 @@
+package TieOut;
+
+sub TIEHANDLE {
+	bless( \(my $scalar), $_[0]);
+}
+
+sub PRINT {
+	my $self = shift;
+	$$self .= join('', @_);
+}
+
+sub PRINTF {
+	my $self = shift;
+    my $fmt  = shift;
+	$$self .= sprintf $fmt, @_;
+}
+
+sub read {
+	my $self = shift;
+	return substr($$self, 0, length($$self), '');
+}
+
+1;
diff --git a/gnu/usr.bin/perl/t/lib/commonsense.t b/gnu/usr.bin/perl/t/lib/commonsense.t
new file mode 100644
index 00000000000..6e313073d29
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/commonsense.t
@@ -0,0 +1,25 @@
+#!./perl
+
+chdir 't' if -d 't';
+@INC = '../lib';
+require Config; import Config;
+if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){
+  print "Bail out! Perl configured without DB_File or [A-Z]DBM_File\n";
+  exit 0;
+}
+if (($Config{'extensions'} !~ /\bFcntl\b/) ){
+  print "Bail out! Perl configured without Fcntl module\n";
+  exit 0;
+}
+if (($Config{'extensions'} !~ /\bIO\b/) ){
+  print "Bail out! Perl configured without IO module\n";
+  exit 0;
+}
+# hey, DOS users do not need this kind of common sense ;-)
+if ($^O ne 'dos' && ($Config{'extensions'} !~ /\bFile\/Glob\b/) ){
+  print "Bail out! Perl configured without File::Glob module\n";
+  exit 0;
+}
+
+print "1..1\nok 1\n";
+
diff --git a/gnu/usr.bin/perl/t/lib/compmod.pl b/gnu/usr.bin/perl/t/lib/compmod.pl
new file mode 100644
index 00000000000..fa032f1acf1
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/compmod.pl
@@ -0,0 +1,19 @@
+#!./perl
+
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+}
+
+my $module = shift;
+
+# 'require open' confuses Perl, so we use instead.
+eval "use $module ();";
+if( $@ ) {
+    print "not ";
+    $@ =~ s/\n/\n# /g;
+    warn "# require failed with '$@'\n";
+}
+print "ok - $module\n";
+
+
diff --git a/gnu/usr.bin/perl/t/lib/filter-util.pl b/gnu/usr.bin/perl/t/lib/filter-util.pl
new file mode 100644
index 00000000000..1bc3bfbd930
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/filter-util.pl
@@ -0,0 +1,56 @@
+
+use strict ;
+use warnings;
+
+use vars qw( $Perl $Inc);
+
+sub readFile
+{
+    my ($filename) = @_ ;
+    my ($string) = '' ;
+
+    open (F, "<$filename") 
+	or die "Cannot open $filename: $!\n" ;
+    while (<F>)
+      { $string .= $_ }
+    close F ;
+    $string ;
+}
+
+sub writeFile
+{
+    my($filename, @strings) = @_ ;
+    open (F, ">$filename") 
+	or die "Cannot open $filename: $!\n" ;
+    binmode(F) if $filename =~ /bin$/i;
+    foreach (@strings)
+      { print F }
+    close F or die "Could not close: $!" ;
+}
+
+sub ok
+{
+    my($number, $result, $note) = @_ ;
+ 
+    $note = "" if ! defined $note ;
+    if ($note) {
+        $note = "# $note" if $note !~ /^\s*#/ ;
+        $note =~ s/^\s*/ / ;
+    }
+
+    print "not " if !$result ;
+    print "ok ${number}${note}\n";
+}
+
+$Inc = '' ;
+foreach (@INC)
+ { $Inc .= "\"-I$_\" " }
+$Inc = "-I::lib" if $^O eq 'MacOS';
+
+$Perl = '' ;
+$Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ;
+
+$Perl = "$Perl -MMac::err=unix" if $^O eq 'MacOS';
+$Perl = "$Perl -w" ;
+
+1;
diff --git a/gnu/usr.bin/perl/t/lib/h2ph.h b/gnu/usr.bin/perl/t/lib/h2ph.h
index cddf0a7d947..c60e8f008d0 100644
--- a/gnu/usr.bin/perl/t/lib/h2ph.h
+++ b/gnu/usr.bin/perl/t/lib/h2ph.h
@@ -38,7 +38,7 @@
 #if !(defined __SOMETHING_MORE_IMPORTANT)
 #    warn Be careful...
 #elif !(defined __SOMETHING_REALLY_REALLY_IMPORTANT)
-#    error Nup, can't go on /* ' /* stupid font-lock-mode */
+#    error "Nup, can't go on" /* ' /* stupid font-lock-mode */
 #else /* defined __SOMETHING_MORE_IMPORTANT && defined __SOMETHING_REALLY_REALLY_IMPORTANT */
 #    define EVERYTHING_IS_OK
 #endif
@@ -82,4 +82,43 @@ typedef struct a_struct {
 typedef enum _days_of_week { sun, mon, tue, wed, thu, fri, sat, Sun=0, Mon,
 			     Tue, Wed, Thu, Fri, Sat } days_of_week;
 
+/* 
+ * Some moderate flexing of tri-graph pre substitution.
+ */
+??=ifndef _SOMETHING_TRIGRAPHIC
+??=define _SOMETHING_TRIGRAPHIC
+??= define SOMETHING_ELSE_TRIGRAPHIC_0 "??!"          /* | ??!|  || */
+ ??=define SOMETHING_ELSE_TRIGRAPHIC_1 "??'"          /* | ??'|  ^| */
+??= define SOMETHING_ELSE_TRIGRAPHIC_2 "??("          /* | ??(|  [| */
+ ??= define SOMETHING_ELSE_TRIGRAPHIC_3 "??)"         /* | ??)|  ]| */
+??=define SOMETHING_ELSE_TRIGRAPHIC_4  "??-0"         /* | ??-|  ~| */
+	??= define SOMETHING_ELSE_TRIGRAPHIC_5 "??/ " /* | ??/|  \| */
+??= define SOMETHING_ELSE_TRIGRAPHIC_6 "??<"          /* | ??<|  {| */
+??=define SOMETHING_ELSE_TRIGRAPHIC_7  "??="          /* | ??=|  #| */
+??= define SOMETHING_ELSE_TRIGRAPHIC_8 "??>"          /* | ??>|  }| */
+	??=endif
+
+// test C++-style comment
+
+#if 1
+typdef struct empty_struct {
+} // trailing C++-style comment should not force continuation
+#endif
+
+/* comments (that look like string) inside enums... */
+
+enum {
+   /* foo;
+     can't
+   */                        
+ };
+
+enum flimflam {
+  flim,
+   /* foo;
+     can't
+   */
+  flam                      
+ } flamflim;
+
 #endif /* _H2PH_H_ */
diff --git a/gnu/usr.bin/perl/t/lib/h2ph.pht b/gnu/usr.bin/perl/t/lib/h2ph.pht
index e5b293243ec..a52c1605f07 100644
--- a/gnu/usr.bin/perl/t/lib/h2ph.pht
+++ b/gnu/usr.bin/perl/t/lib/h2ph.pht
@@ -29,7 +29,7 @@ unless(defined(&_H2PH_H_)) {
     if(!(defined (defined(&__SOMETHING_MORE_IMPORTANT) ? &__SOMETHING_MORE_IMPORTANT : 0))) {
     }
  elsif(!(defined (defined(&__SOMETHING_REALLY_REALLY_IMPORTANT) ? &__SOMETHING_REALLY_REALLY_IMPORTANT : 0))) {
-	die("Nup\,\ can\'t\ go\ on\ ");
+	die("Nup, can't go on");
     } else {
 	eval 'sub EVERYTHING_IS_OK () {1;}' unless defined(&EVERYTHING_IS_OK);
     }
@@ -67,5 +67,21 @@ unless(defined(&_H2PH_H_)) {
     eval("sub Thu () { 4; }") unless defined(&Thu);
     eval("sub Fri () { 5; }") unless defined(&Fri);
     eval("sub Sat () { 6; }") unless defined(&Sat);
+    unless(defined(&_SOMETHING_TRIGRAPHIC)) {
+	eval 'sub _SOMETHING_TRIGRAPHIC () {1;}' unless defined(&_SOMETHING_TRIGRAPHIC);
+	eval 'sub SOMETHING_ELSE_TRIGRAPHIC_0 () {"|";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_0);
+	eval 'sub SOMETHING_ELSE_TRIGRAPHIC_1 () {"^";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_1);
+	eval 'sub SOMETHING_ELSE_TRIGRAPHIC_2 () {"[";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_2);
+	eval 'sub SOMETHING_ELSE_TRIGRAPHIC_3 () {"]";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_3);
+	eval 'sub SOMETHING_ELSE_TRIGRAPHIC_4 () {"~0";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_4);
+	eval 'sub SOMETHING_ELSE_TRIGRAPHIC_5 () {"\\ ";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_5);
+	eval 'sub SOMETHING_ELSE_TRIGRAPHIC_6 () {"{";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_6);
+	eval 'sub SOMETHING_ELSE_TRIGRAPHIC_7 () {"#";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_7);
+	eval 'sub SOMETHING_ELSE_TRIGRAPHIC_8 () {"}";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_8);
+    }
+    if(1) {
+    }
+    eval("sub flim () { 0; }") unless defined(&flim);
+    eval("sub flam () { 1; }") unless defined(&flam);
 }
 1;
diff --git a/gnu/usr.bin/perl/t/lib/locale/latin1 b/gnu/usr.bin/perl/t/lib/locale/latin1
new file mode 100644
index 00000000000..8499ca46ee5
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/locale/latin1
@@ -0,0 +1,11 @@
+no utf8; # naked Latin-1
+$locales .= <<EOF;
+Català Catalan:ca:es:1 15
+Français French:fr:be ca ch fr lu:1 15
+Gáidhlig Gaelic:gd:gb uk:1 14 15
+Føroyskt Faroese:fo:fo:1 15
+Íslensku Icelandic:is:is:1 15
+Sámi Lappish:::4 6 13
+Português Portuguese:po:po br:1 15
+Espanõl Spanish:es:ar bo cl co cr do ec es gt hn mx ni pa pe py sv uy ve:1 15
+EOF
diff --git a/gnu/usr.bin/perl/t/lib/locale/utf8 b/gnu/usr.bin/perl/t/lib/locale/utf8
new file mode 100644
index 00000000000..69bc505038a
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/locale/utf8
@@ -0,0 +1,11 @@
+use utf8;
+$locales .= <<EOF;
+Català Catalan:ca:es:1 15
+Français French:fr:be ca ch fr lu:1 15
+Gáidhlig Gaelic:gd:gb uk:1 14 15
+Føroyskt Faroese:fo:fo:1 15
+�slensku Icelandic:is:is:1 15
+Sámi Lappish:::4 6 13
+Português Portuguese:po:po br:1 15
+Espanõl Spanish:es:ar bo cl co cr do ec es gt hn mx ni pa pe py sv uy ve:1 15
+EOF
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/bailout b/gnu/usr.bin/perl/t/lib/sample-tests/bailout
new file mode 100644
index 00000000000..f67f673e7d3
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/bailout
@@ -0,0 +1,9 @@
+print <<DUMMY_TEST;
+1..5
+ok 1
+ok 2
+ok 3
+Bail out!  GERONIMMMOOOOOO!!!
+ok 4
+ok 5
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/bignum b/gnu/usr.bin/perl/t/lib/sample-tests/bignum
new file mode 100644
index 00000000000..3f51d38a424
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/bignum
@@ -0,0 +1,7 @@
+print <<DUMMY;
+1..2
+ok 1
+ok 2
+ok 100001
+ok 136211425
+DUMMY
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/combined b/gnu/usr.bin/perl/t/lib/sample-tests/combined
new file mode 100644
index 00000000000..8dfaa28e926
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/combined
@@ -0,0 +1,13 @@
+print <<DUMMY_TEST;
+1..10 todo 4 10
+ok 1
+ok 2 basset hounds got long ears
+not ok 3        all hell broke lose
+ok 4
+ok
+ok 6
+ok 7            # Skip contract negociations
+ok 8
+not ok 9
+not ok 10
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/descriptive b/gnu/usr.bin/perl/t/lib/sample-tests/descriptive
new file mode 100644
index 00000000000..e165ac1bf5c
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/descriptive
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok 1    Interlock activated
+ok 2    Megathrusters are go
+ok 3    Head formed
+ok 4    Blazing sword formed
+ok 5    Robeast destroyed
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/die b/gnu/usr.bin/perl/t/lib/sample-tests/die
new file mode 100644
index 00000000000..4c8534082da
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/die
@@ -0,0 +1,2 @@
+use if ($^O eq 'VMS'), vmsish => 'hushed';
+exit 1;  # exit because die() can be noisy
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/die_head_end b/gnu/usr.bin/perl/t/lib/sample-tests/die_head_end
new file mode 100644
index 00000000000..afcea1b3c83
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/die_head_end
@@ -0,0 +1,9 @@
+print <<DUMMY_TEST;
+ok 1
+ok 2
+ok 3
+ok 4
+DUMMY_TEST
+
+use if $^O eq 'VMS', vmsish => 'hushed';
+exit 1;
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/die_last_minute b/gnu/usr.bin/perl/t/lib/sample-tests/die_last_minute
new file mode 100644
index 00000000000..e421dd1c0e2
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/die_last_minute
@@ -0,0 +1,10 @@
+print <<DUMMY_TEST;
+ok 1
+ok 2
+ok 3
+ok 4
+1..4
+DUMMY_TEST
+
+use if $^O eq 'VMS', vmsish => 'hushed';
+exit 1;
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/duplicates b/gnu/usr.bin/perl/t/lib/sample-tests/duplicates
new file mode 100644
index 00000000000..63f6a706b63
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/duplicates
@@ -0,0 +1,14 @@
+print <<DUMMY_TEST
+1..10
+ok 1
+ok 2
+ok 3
+ok 4
+ok 4
+ok 5
+ok 6
+ok 7
+ok 8
+ok 9
+ok 10
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/head_end b/gnu/usr.bin/perl/t/lib/sample-tests/head_end
new file mode 100644
index 00000000000..14a32f2fe6b
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/head_end
@@ -0,0 +1,11 @@
+print <<DUMMY_TEST;
+# comments
+ok 1
+ok 2
+ok 3
+ok 4
+# comment
+1..4
+# more ignored stuff
+# and yet more
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/head_fail b/gnu/usr.bin/perl/t/lib/sample-tests/head_fail
new file mode 100644
index 00000000000..9d1667ab19a
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/head_fail
@@ -0,0 +1,11 @@
+print <<DUMMY_TEST;
+# comments
+ok 1
+not ok 2
+ok 3
+ok 4
+# comment
+1..4
+# more ignored stuff
+# and yet more
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/lone_not_bug b/gnu/usr.bin/perl/t/lib/sample-tests/lone_not_bug
new file mode 100644
index 00000000000..10eaa2a3b02
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/lone_not_bug
@@ -0,0 +1,9 @@
+# There was a bug where the first test would be considered a
+# 'lone not' failure.
+print <<DUMMY;
+ok 1
+ok 2
+ok 3
+ok 4
+1..4
+DUMMY
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/no_nums b/gnu/usr.bin/perl/t/lib/sample-tests/no_nums
new file mode 100644
index 00000000000..c32d3f22baa
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/no_nums
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok
+ok
+not ok
+ok
+ok
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/out_of_order b/gnu/usr.bin/perl/t/lib/sample-tests/out_of_order
new file mode 100644
index 00000000000..77641aa3620
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/out_of_order
@@ -0,0 +1,22 @@
+# From a bungled core thread test.
+#
+# The important thing here is that the last test is the right test.
+# Test::Harness would misparse this as being a valid test.
+print <<DUMMY;
+ok 2 - Test that argument passing works
+ok 3 - Test that passing arguments as references work
+ok 4 - Test a normal sub
+ok 6 - Detach test
+ok 8 - Nested thread test
+ok 9 - Nested thread test
+ok 10 - Wanted 7, got 7
+ok 11 - Wanted 7, got 7
+ok 12 - Wanted 8, got 8
+ok 13 - Wanted 8, got 8
+1..15
+ok 1
+ok 5 - Check that Config::threads is true
+ok 7 - Detach test
+ok 14 - Check so that tid for threads work for main thread
+ok 15 - Check so that tid for threads work for main thread
+DUMMY
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/shbang_misparse b/gnu/usr.bin/perl/t/lib/sample-tests/shbang_misparse
new file mode 100644
index 00000000000..bc1b524a347
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/shbang_misparse
@@ -0,0 +1,12 @@
+#!/usr/bin/perl-latest
+
+# The above #! line was misparsed as having a -t.
+# Pre-5.8 this will simply cause perl to choke, since there was no -t.
+# Post-5.8 taint warnings will mistakenly be on.
+
+print "1..2\n";
+print "ok 1\n";
+my $warning = '';
+$SIG{__WARN__} = sub { $warning .= $_[0] };
+eval("#" . substr($0, 0, 0));
+print $warning ? "not ok 2\n" : "ok 2\n";
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/simple b/gnu/usr.bin/perl/t/lib/sample-tests/simple
new file mode 100644
index 00000000000..d6b85846b26
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/simple
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/simple_fail b/gnu/usr.bin/perl/t/lib/sample-tests/simple_fail
new file mode 100644
index 00000000000..aa65f5f66de
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/simple_fail
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok 1
+not ok 2
+ok 3
+ok 4
+not ok 5
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/skip b/gnu/usr.bin/perl/t/lib/sample-tests/skip
new file mode 100644
index 00000000000..1b43d12f3b9
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/skip
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5
+ok 1
+ok 2    # skipped rain delay
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/skip_nomsg b/gnu/usr.bin/perl/t/lib/sample-tests/skip_nomsg
new file mode 100644
index 00000000000..51d1ed6b43f
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/skip_nomsg
@@ -0,0 +1,4 @@
+print <<DUMMY;
+1..1
+ok 1 # Skip
+DUMMY
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/skipall b/gnu/usr.bin/perl/t/lib/sample-tests/skipall
new file mode 100644
index 00000000000..8c4679660c2
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/skipall
@@ -0,0 +1,3 @@
+print <<DUMMY_TEST;
+1..0 # skip: rope
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/skipall_nomsg b/gnu/usr.bin/perl/t/lib/sample-tests/skipall_nomsg
new file mode 100644
index 00000000000..9b0dc11a697
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/skipall_nomsg
@@ -0,0 +1,2 @@
+print "1..0\n";
+exit 0;
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/taint b/gnu/usr.bin/perl/t/lib/sample-tests/taint
new file mode 100644
index 00000000000..42968d36e32
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/taint
@@ -0,0 +1,7 @@
+#!/usr/bin/perl -Tw
+
+use lib qw(t/lib);
+use Test::More tests => 1;
+
+eval { kill 0, $^X };
+like( $@, '/^Insecure dependency/',   '-T honored' );
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/todo b/gnu/usr.bin/perl/t/lib/sample-tests/todo
new file mode 100644
index 00000000000..5620ee20ee0
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/todo
@@ -0,0 +1,8 @@
+print <<DUMMY_TEST;
+1..5 todo 3   2;
+ok 1
+ok 2
+not ok 3
+ok 4
+ok 5
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/todo_inline b/gnu/usr.bin/perl/t/lib/sample-tests/todo_inline
new file mode 100644
index 00000000000..5b96d68caf2
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/todo_inline
@@ -0,0 +1,6 @@
+print <<DUMMY_TEST;
+1..3
+not ok 1 - Foo # TODO Just testing the todo interface.
+ok 2 - Unexpected success # TODO Just testing the todo interface.
+ok 3 - This is not todo
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/vms_nit b/gnu/usr.bin/perl/t/lib/sample-tests/vms_nit
new file mode 100644
index 00000000000..1df7804309f
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/vms_nit
@@ -0,0 +1,6 @@
+print <<DUMMY;
+1..2
+not 
+ok 1
+ok 2
+DUMMY
diff --git a/gnu/usr.bin/perl/t/lib/sample-tests/with_comments b/gnu/usr.bin/perl/t/lib/sample-tests/with_comments
new file mode 100644
index 00000000000..7aa913985b1
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/sample-tests/with_comments
@@ -0,0 +1,14 @@
+print <<DUMMY_TEST;
+# and stuff
+1..5 todo 1 2 4 5;
+# yeah, that
+not ok 1
+# Failed test 1 in t/todo.t at line 9 *TODO*
+ok 2 # (t/todo.t at line 10 TODO?!)
+ok 3
+not ok 4
+# Test 4 got: '0' (t/todo.t at line 12 *TODO*)
+#   Expected: '1' (need more tuits)
+ok 5 # (t/todo.t at line 13 TODO?!)
+# woo
+DUMMY_TEST
diff --git a/gnu/usr.bin/perl/t/lib/strict/refs b/gnu/usr.bin/perl/t/lib/strict/refs
new file mode 100644
index 00000000000..10599b0bb28
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/strict/refs
@@ -0,0 +1,297 @@
+Check strict refs functionality
+
+__END__
+
+# no strict, should build & run ok.
+my $fred ;
+$b = "fred" ;
+$a = $$b ;
+$c = ${"def"} ;
+$c = @{"def"} ;
+$c = %{"def"} ;
+$c = *{"def"} ;
+$c = \&{"def"} ;
+$c = def->[0];
+$c = def->{xyz};
+EXPECT
+
+########
+
+# strict refs - error
+use strict ;
+my $fred ;
+my $a = ${"fred"} ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $fred ;
+my $a = ${"fred"} ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $fred ;
+my $b = "fred" ;
+my $a = $$b ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 6.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $b ;
+my $a = $$b ;
+EXPECT
+Can't use an undefined value as a SCALAR reference at - line 5.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $b ;
+my $a = @$b ;
+EXPECT
+Can't use an undefined value as an ARRAY reference at - line 5.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $b ;
+my $a = %$b ;
+EXPECT
+Can't use an undefined value as a HASH reference at - line 5.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $b ;
+my $a = *$b ;
+EXPECT
+Can't use an undefined value as a symbol reference at - line 5.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $a = fred->[0] ;
+EXPECT
+Can't use bareword ("fred") as an ARRAY ref while "strict refs" in use at - line 4.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $a = fred->{barney} ;
+EXPECT
+Can't use bareword ("fred") as a HASH ref while "strict refs" in use at - line 4.
+########
+
+# strict refs - no error
+use strict ;
+no strict 'refs' ;
+my $fred ;
+my $b = "fred" ;
+my $a = $$b ;
+use strict 'refs' ;
+EXPECT
+
+########
+
+# strict refs - no error
+use strict qw(subs vars) ;
+my $fred ;
+my $b = "fred" ;
+my $a = $$b ;
+use strict 'refs' ;
+EXPECT
+
+########
+
+# strict refs - no error
+my $fred ;
+my $b = "fred" ;
+my $a = $$b ;
+use strict 'refs' ;
+EXPECT
+
+########
+
+# strict refs - no error
+use strict 'refs' ;
+my $fred ;
+my $b = \$fred ;
+my $a = $$b ;
+EXPECT
+
+########
+
+# Check runtime scope of strict refs pragma
+use strict 'refs';
+my $fred ;
+my $b = "fred" ;
+{
+    no strict ;
+    my $a = $$b ;
+}
+my $a = $$b ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10.
+########
+
+# Check runtime scope of strict refs pragma
+no strict ;
+my $fred ;
+my $b = "fred" ;
+{
+    use strict 'refs' ;
+    my $a = $$b ;
+}
+my $a = $$b ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8.
+########
+
+# Check runtime scope of strict refs pragma
+no strict ;
+my $fred ;
+my $b = "fred" ;
+{
+    use strict 'refs' ;
+    $a = sub { my $c = $$b ; }
+}
+&$a ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8.
+########
+
+
+--FILE-- abc
+my $a = ${"Fred"} ;
+1;
+--FILE-- 
+use strict 'refs' ;
+require "./abc";
+EXPECT
+
+########
+
+--FILE-- abc
+use strict 'refs' ;
+1;
+--FILE-- 
+require "./abc";
+my $a = ${"Fred"} ;
+EXPECT
+
+########
+
+--FILE-- abc
+use strict 'refs' ;
+my $a = ${"Fred"} ;
+1;
+--FILE-- 
+${"Fred"} ;
+require "./abc";
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2.
+Compilation failed in require at - line 2.
+########
+
+--FILE-- abc.pm
+use strict 'refs' ;
+my $a = ${"Fred"} ;
+1;
+--FILE-- 
+my $a = ${"Fred"} ;
+use abc;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2.
+Compilation failed in require at - line 2.
+BEGIN failed--compilation aborted at - line 2.
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval {
+    my $a = ${"Fred"} ;
+};
+print STDERR $@ ;
+my $a = ${"Fred"} ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval {
+    use strict 'refs' ;
+    my $a = ${"Fred"} ;
+};
+print STDERR $@ ;
+my $a = ${"Fred"} ;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 6.
+########
+
+# Check scope of pragma with eval
+use strict 'refs' ;
+eval {
+    my $a = ${"Fred"} ;
+};
+print STDERR $@ ;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 5.
+########
+
+# Check scope of pragma with eval
+use strict 'refs' ;
+eval {
+    no strict ;
+    my $a = ${"Fred"} ;
+};
+print STDERR $@ ;
+my $a = ${"Fred"} ;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 9.
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval '
+    my $a = ${"Fred"} ;
+'; print STDERR $@ ;
+my $a = ${"Fred"} ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval q[ 
+    use strict 'refs' ;
+    my $a = ${"Fred"} ;
+]; print STDERR $@;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 3.
+########
+
+# Check scope of pragma with eval
+use strict 'refs' ;
+eval '
+    my $a = ${"Fred"} ;
+'; print STDERR $@ ;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 2.
+########
+
+# Check scope of pragma with eval
+use strict 'refs' ;
+eval '
+    no strict ;
+    my $a = ${"Fred"} ;
+'; print STDERR $@;
+my $a = ${"Fred"} ;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 8.
diff --git a/gnu/usr.bin/perl/t/lib/strict/subs b/gnu/usr.bin/perl/t/lib/strict/subs
new file mode 100644
index 00000000000..4a90809020f
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/strict/subs
@@ -0,0 +1,347 @@
+Check strict subs functionality
+
+__END__
+
+# no strict, should build & run ok.
+Fred ;
+my $fred ;
+$b = "fred" ;
+$a = $$b ;
+EXPECT
+
+########
+
+use strict qw(refs vars);
+Fred ;
+EXPECT
+
+########
+
+use strict ;
+no strict 'subs' ;
+Fred ;
+EXPECT
+
+########
+
+# strict subs - error
+use strict 'subs' ;
+my @a = (1..2);
+my $b = xyz;
+EXPECT
+Bareword "xyz" not allowed while "strict subs" in use at - line 5.
+Execution of - aborted due to compilation errors.
+########
+
+# strict subs - error
+use strict 'subs' ;
+Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 4.
+Execution of - aborted due to compilation errors.
+########
+
+# strict subs - error
+use strict 'subs' ;
+my @a = (A..Z);
+EXPECT
+Bareword "Z" not allowed while "strict subs" in use at - line 4.
+Bareword "A" not allowed while "strict subs" in use at - line 4.
+Execution of - aborted due to compilation errors.
+########
+
+# strict subs - error
+use strict 'subs' ;
+my $a = (B..Y);
+EXPECT
+Bareword "Y" not allowed while "strict subs" in use at - line 4.
+Bareword "B" not allowed while "strict subs" in use at - line 4.
+Execution of - aborted due to compilation errors.
+########
+
+# strict subs - error
+use strict ;
+Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 4.
+Execution of - aborted due to compilation errors.
+########
+
+# strict subs - no error
+use strict 'subs' ;
+sub Fred {}
+Fred ;
+EXPECT
+
+########
+
+# Check compile time scope of strict subs pragma
+use strict 'subs' ;
+{
+    no strict ;
+    my $a = Fred ;
+}
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 8.
+Execution of - aborted due to compilation errors.
+########
+
+# Check compile time scope of strict subs pragma
+no strict;
+{
+    use strict 'subs' ;
+    my $a = Fred ;
+}
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 6.
+Execution of - aborted due to compilation errors.
+########
+
+# Check compile time scope of strict vars pragma
+use strict 'vars' ;
+{
+    no strict ;
+    $joe = 1 ;
+}
+$joe = 1 ;
+EXPECT
+Variable "$joe" is not imported at - line 8.
+Global symbol "$joe" requires explicit package name at - line 8.
+Execution of - aborted due to compilation errors.
+########
+
+# Check compile time scope of strict vars pragma
+no strict;
+{
+    use strict 'vars' ;
+    $joe = 1 ;
+}
+$joe = 1 ;
+EXPECT
+Global symbol "$joe" requires explicit package name at - line 6.
+Execution of - aborted due to compilation errors.
+########
+
+# Check runtime scope of strict refs pragma
+use strict 'refs';
+my $fred ;
+my $b = "fred" ;
+{
+    no strict ;
+    my $a = $$b ;
+}
+my $a = $$b ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10.
+########
+
+# Check runtime scope of strict refs pragma
+no strict ;
+my $fred ;
+my $b = "fred" ;
+{
+    use strict 'refs' ;
+    my $a = $$b ;
+}
+my $a = $$b ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8.
+########
+
+# Check runtime scope of strict refs pragma
+no strict ;
+my $fred ;
+my $b = "fred" ;
+{
+    use strict 'refs' ;
+    $a = sub { my $c = $$b ; }
+}
+&$a ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8.
+########
+
+use strict 'subs' ;
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 3.
+Execution of - aborted due to compilation errors.
+########
+
+--FILE-- abc
+my $a = Fred ;
+1;
+--FILE-- 
+use strict 'subs' ;
+require "./abc";
+EXPECT
+
+########
+
+--FILE-- abc
+use strict 'subs' ;
+1;
+--FILE-- 
+require "./abc";
+my $a = Fred ;
+EXPECT
+
+########
+
+--FILE-- abc
+use strict 'subs' ;
+my $a = Fred ;
+1;
+--FILE-- 
+Fred ;
+require "./abc";
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at ./abc line 2.
+Compilation failed in require at - line 2.
+########
+
+--FILE-- abc.pm
+use strict 'subs' ;
+my $a = Fred ;
+1;
+--FILE-- 
+Fred ;
+use abc;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at abc.pm line 2.
+Compilation failed in require at - line 2.
+BEGIN failed--compilation aborted at - line 2.
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval {
+    my $a = Fred ;
+};
+print STDERR $@;
+my $a = Fred ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval {
+    use strict 'subs' ;
+    my $a = Fred ;
+};
+print STDERR $@;
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 6.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
+use strict 'subs' ;
+eval {
+    my $a = Fred ;
+};
+print STDERR $@;
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 5.
+Bareword "Fred" not allowed while "strict subs" in use at - line 8.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
+use strict 'subs' ;
+eval {
+    no strict ;
+    my $a = Fred ;
+};
+print STDERR $@;
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 9.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval '
+    Fred ;
+'; print STDERR $@ ;
+Fred ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval q[ 
+    use strict 'subs' ;
+    Fred ;
+]; print STDERR $@;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 3.
+########
+
+# Check scope of pragma with eval
+use strict 'subs' ;
+eval '
+    Fred ;
+'; print STDERR $@ ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 2.
+########
+
+# Check scope of pragma with eval
+use strict 'subs' ;
+eval '
+    no strict ;
+    my $a = Fred ;
+'; print STDERR $@;
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 8.
+Execution of - aborted due to compilation errors.
+########
+
+# see if Foo->Bar(...) etc work under strictures
+use strict;
+package Foo; sub Bar { print "@_\n" }
+Foo->Bar('a',1);
+Bar Foo ('b',2);
+Foo->Bar(qw/c 3/);
+Bar Foo (qw/d 4/);
+Foo::->Bar('A',1);
+Bar Foo:: ('B',2);
+Foo::->Bar(qw/C 3/);
+Bar Foo:: (qw/D 4/);
+EXPECT
+Foo a 1
+Foo b 2
+Foo c 3
+Foo d 4
+Foo A 1
+Foo B 2
+Foo C 3
+Foo D 4
+########
+
+# Check that barewords on the RHS of a regex match are caught
+use strict;
+"" =~ foo;
+EXPECT
+Bareword "foo" not allowed while "strict subs" in use at - line 4.
+Execution of - aborted due to compilation errors.
+
+########
+
+# ID 20020703.002
+use strict;
+use warnings;
+my $abc = XYZ ? 1 : 0;
+print "$abc\n";
+EXPECT
+Bareword "XYZ" not allowed while "strict subs" in use at - line 5.
+Execution of - aborted due to compilation errors.
diff --git a/gnu/usr.bin/perl/t/lib/strict/vars b/gnu/usr.bin/perl/t/lib/strict/vars
new file mode 100644
index 00000000000..de517078be1
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/strict/vars
@@ -0,0 +1,423 @@
+Check strict vars functionality
+
+__END__
+
+# no strict, should build & run ok.
+Fred ;
+my $fred ;
+$b = "fred" ;
+$a = $$b ;
+EXPECT
+
+########
+
+use strict qw(subs refs) ;
+$fred ;
+EXPECT
+
+########
+
+use strict ;
+no strict 'vars' ;
+$fred ;
+EXPECT
+
+########
+
+# strict vars - no error
+use strict 'vars' ;
+use vars qw( $freddy) ;
+BEGIN { *freddy = \$joe::shmoe; }
+$freddy = 2 ;
+EXPECT
+
+########
+
+# strict vars - no error
+use strict 'vars' ;
+use vars qw( $freddy) ;
+local $abc::joe ;
+my $fred ;
+my $b = \$fred ;
+$Fred::ABC = 1 ;
+$freddy = 2 ;
+EXPECT
+
+########
+
+# strict vars - error
+use strict ;
+$fred ;
+EXPECT
+Global symbol "$fred" requires explicit package name at - line 4.
+Execution of - aborted due to compilation errors.
+########
+
+# strict vars - error
+use strict 'vars' ;
+<$fred> ;
+EXPECT
+Global symbol "$fred" requires explicit package name at - line 4.
+Execution of - aborted due to compilation errors.
+########
+
+# strict vars - error
+use strict 'vars' ;
+local $fred ;
+EXPECT
+Global symbol "$fred" requires explicit package name at - line 4.
+Execution of - aborted due to compilation errors.
+########
+
+# Check compile time scope of strict vars pragma
+use strict 'vars' ;
+{
+    no strict ;
+    $joe = 1 ;
+}
+$joe = 1 ;
+EXPECT
+Variable "$joe" is not imported at - line 8.
+Global symbol "$joe" requires explicit package name at - line 8.
+Execution of - aborted due to compilation errors.
+########
+
+# Check compile time scope of strict vars pragma
+no strict;
+{
+    use strict 'vars' ;
+    $joe = 1 ;
+}
+$joe = 1 ;
+EXPECT
+Global symbol "$joe" requires explicit package name at - line 6.
+Execution of - aborted due to compilation errors.
+########
+
+--FILE-- abc
+$joe = 1 ;
+1;
+--FILE-- 
+use strict 'vars' ;
+require "./abc";
+EXPECT
+
+########
+
+--FILE-- abc
+use strict 'vars' ;
+1;
+--FILE-- 
+require "./abc";
+$joe = 1 ;
+EXPECT
+
+########
+
+--FILE-- abc
+use strict 'vars' ;
+$joe = 1 ;
+1;
+--FILE-- 
+$joe = 1 ;
+require "./abc";
+EXPECT
+Variable "$joe" is not imported at ./abc line 2.
+Global symbol "$joe" requires explicit package name at ./abc line 2.
+Compilation failed in require at - line 2.
+########
+
+--FILE-- abc.pm
+use strict 'vars' ;
+$joe = 1 ;
+1;
+--FILE-- 
+$joe = 1 ;
+use abc;
+EXPECT
+Variable "$joe" is not imported at abc.pm line 2.
+Global symbol "$joe" requires explicit package name at abc.pm line 2.
+Compilation failed in require at - line 2.
+BEGIN failed--compilation aborted at - line 2.
+########
+
+--FILE-- abc.pm
+package Burp;
+use strict;
+$a = 1;$f = 1;$k = 1; # just to get beyond the limit...
+$b = 1;$g = 1;$l = 1;
+$c = 1;$h = 1;$m = 1;
+$d = 1;$i = 1;$n = 1;
+$e = 1;$j = 1;$o = 1;
+$p = 0b12;
+--FILE-- 
+use abc;
+EXPECT
+Global symbol "$f" requires explicit package name at abc.pm line 3.
+Global symbol "$k" requires explicit package name at abc.pm line 3.
+Global symbol "$g" requires explicit package name at abc.pm line 4.
+Global symbol "$l" requires explicit package name at abc.pm line 4.
+Global symbol "$c" requires explicit package name at abc.pm line 5.
+Global symbol "$h" requires explicit package name at abc.pm line 5.
+Global symbol "$m" requires explicit package name at abc.pm line 5.
+Global symbol "$d" requires explicit package name at abc.pm line 6.
+Global symbol "$i" requires explicit package name at abc.pm line 6.
+Global symbol "$n" requires explicit package name at abc.pm line 6.
+Global symbol "$e" requires explicit package name at abc.pm line 7.
+Global symbol "$j" requires explicit package name at abc.pm line 7.
+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 1.
+BEGIN failed--compilation aborted at - line 1.
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval {
+    $joe = 1 ;
+};
+print STDERR $@;
+$joe = 1 ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval {
+    use strict 'vars' ;
+    $joe = 1 ;
+};
+print STDERR $@;
+$joe = 1 ;
+EXPECT
+Global symbol "$joe" requires explicit package name at - line 6.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
+use strict 'vars' ;
+eval {
+    $joe = 1 ;
+};
+print STDERR $@;
+$joe = 1 ;
+EXPECT
+Global symbol "$joe" requires explicit package name at - line 5.
+Global symbol "$joe" requires explicit package name at - line 8.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
+use strict 'vars' ;
+eval {
+    no strict ;
+    $joe = 1 ;
+};
+print STDERR $@;
+$joe = 1 ;
+EXPECT
+Variable "$joe" is not imported at - line 9.
+Global symbol "$joe" requires explicit package name at - line 9.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval '
+    $joe = 1 ;
+'; print STDERR $@ ;
+$joe = 1 ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval q[ 
+    use strict 'vars' ;
+    $joe = 1 ;
+]; print STDERR $@;
+EXPECT
+Global symbol "$joe" requires explicit package name at (eval 1) line 3.
+########
+
+# Check scope of pragma with eval
+use strict 'vars' ;
+eval '
+    $joe = 1 ;
+'; print STDERR $@ ;
+EXPECT
+Global symbol "$joe" requires explicit package name at (eval 1) line 2.
+########
+
+# Check scope of pragma with eval
+use strict 'vars' ;
+eval '
+    no strict ;
+    $joe = 1 ;
+'; print STDERR $@;
+$joe = 1 ;
+EXPECT
+Global symbol "$joe" requires explicit package name at - line 8.
+Execution of - aborted due to compilation errors.
+########
+
+# Check if multiple evals produce same errors
+use strict 'vars';
+my $ret = eval q{ print $x; };
+print $@;
+print "ok 1\n" unless defined $ret;
+$ret = eval q{ print $x; };
+print $@;
+print "ok 2\n" unless defined $ret;
+EXPECT
+Global symbol "$x" requires explicit package name at (eval 1) line 1.
+ok 1
+Global symbol "$x" requires explicit package name at (eval 2) line 1.
+ok 2
+########
+
+# strict vars with outer our - no error
+use strict 'vars' ;
+our $freddy;
+local $abc::joe ;
+my $fred ;
+my $b = \$fred ;
+$Fred::ABC = 1 ;
+$freddy = 2 ;
+EXPECT
+
+########
+
+# strict vars with inner our - no error
+use strict 'vars' ;
+sub foo {
+    our $fred;
+    $fred;
+}
+EXPECT
+
+########
+
+# strict vars with outer our, inner use - no error
+use strict 'vars' ;
+our $fred;
+sub foo {
+    $fred;
+}
+EXPECT
+
+########
+
+# strict vars with nested our - no error
+use strict 'vars' ;
+our $fred;
+sub foo {
+    our $fred;
+    $fred;
+}
+$fred ;
+EXPECT
+
+########
+
+# strict vars with elapsed our - error
+use strict 'vars' ;
+sub foo {
+    our $fred;
+    $fred;
+}
+$fred ;
+EXPECT
+Variable "$fred" is not imported at - line 8.
+Global symbol "$fred" requires explicit package name at - line 8.
+Execution of - aborted due to compilation errors.
+########
+
+# nested our with local - no error
+$fred = 1;
+use strict 'vars';
+{
+    local our $fred = 2;
+    print $fred,"\n";
+}
+print our $fred,"\n";
+EXPECT
+2
+1
+########
+
+# "nailed" our declaration visibility across package boundaries
+use strict 'vars';
+our $foo;
+$foo = 20;
+package Foo;
+print $foo, "\n";
+EXPECT
+20
+########
+
+# multiple our declarations in same scope, different packages, no warning
+use strict 'vars';
+use warnings;
+our $foo;
+${foo} = 10;
+package Foo;
+our $foo = 20;
+print $foo, "\n";
+EXPECT
+20
+########
+
+# multiple our declarations in same scope, same package, warning
+use strict 'vars';
+use warnings;
+our $foo;
+${foo} = 10;
+our $foo;
+EXPECT
+"our" variable $foo masks earlier declaration in same scope at - line 7.
+########
+
+# multiple our declarations in same scope, same package, warning
+use strict 'vars';
+use warnings;
+{ our $x = 1 }
+{ our $x = 0 }
+our $foo;
+{
+    our $foo;
+    package Foo;
+    our $foo;
+}
+EXPECT
+"our" variable $foo redeclared at - line 9.
+	(Did you mean "local" instead of "our"?)
+########
+
+--FILE-- abc
+ok
+--FILE-- 
+# check if our variables are introduced correctly in readline()
+package Foo;
+use strict 'vars';
+our $FH;
+open $FH, "abc" or die "Can't open 'abc': $!";
+print <$FH>;
+close $FH;
+EXPECT
+ok
+########
+
+# 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/gnu/usr.bin/perl/t/lib/warnings/1global b/gnu/usr.bin/perl/t/lib/warnings/1global
new file mode 100644
index 00000000000..0af80221b25
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/1global
@@ -0,0 +1,189 @@
+Check existing $^W functionality
+
+
+__END__
+
+# warnable code, warnings disabled
+$a =+ 3 ;
+EXPECT
+
+########
+-w
+# warnable code, warnings enabled via command line switch
+$a =+ 3 ;
+EXPECT
+Reversed += operator at - line 3.
+Name "main::a" used only once: possible typo at - line 3.
+########
+#! perl -w
+# warnable code, warnings enabled via #! line
+$a =+ 3 ;
+EXPECT
+Reversed += operator at - line 3.
+Name "main::a" used only once: possible typo at - line 3.
+########
+
+# warnable code, warnings enabled via compile time $^W
+BEGIN { $^W = 1 }
+$a =+ 3 ;
+EXPECT
+Reversed += operator at - line 4.
+Name "main::a" used only once: possible typo at - line 4.
+########
+
+# compile-time warnable code, warnings enabled via runtime $^W
+# so no warning printed.
+$^W = 1 ;
+$a =+ 3 ;
+EXPECT
+
+########
+
+# warnable code, warnings enabled via runtime $^W
+$^W = 1 ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 4.
+########
+
+# warnings enabled at compile time, disabled at run time
+BEGIN { $^W = 1 }
+$^W = 0 ;
+my $b ; chop $b ;
+EXPECT
+
+########
+
+# warnings disabled at compile time, enabled at run time
+BEGIN { $^W = 0 }
+$^W = 1 ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 5.
+########
+-w
+--FILE-- abcd
+my $b ; chop $b ;
+1 ;
+--FILE-- 
+require "./abcd";
+EXPECT
+Use of uninitialized value in scalar chop at ./abcd line 1.
+########
+
+--FILE-- abcd
+my $b ; chop $b ;
+1 ;
+--FILE-- 
+#! perl -w
+require "./abcd";
+EXPECT
+Use of uninitialized value in scalar chop at ./abcd line 1.
+########
+
+--FILE-- abcd
+my $b ; chop $b ;
+1 ;
+--FILE-- 
+$^W =1 ;
+require "./abcd";
+EXPECT
+Use of uninitialized value in scalar chop at ./abcd line 1.
+########
+
+--FILE-- abcd
+$^W = 0;
+my $b ; chop $b ;
+1 ;
+--FILE-- 
+$^W =1 ;
+require "./abcd";
+EXPECT
+
+########
+
+--FILE-- abcd
+$^W = 1;
+1 ;
+--FILE-- 
+$^W =0 ;
+require "./abcd";
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 3.
+########
+
+$^W = 1;
+eval 'my $b ; chop $b ;' ;
+print $@ ;
+EXPECT
+Use of uninitialized value in scalar chop at (eval 1) line 1.
+########
+
+eval '$^W = 1;' ;
+print $@ ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 4.
+########
+
+eval {$^W = 1;} ;
+print $@ ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 4.
+########
+
+{
+    local ($^W) = 1;
+}
+my $b ; chop $b ;
+EXPECT
+
+########
+
+my $a ; chop $a ;
+{
+    local ($^W) = 1;
+    my $b ; chop $b ;
+}
+my $c ; chop $c ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 5.
+########
+-w
+-e undef
+EXPECT
+Use of uninitialized value in -e at - line 2.
+########
+
+$^W = 1 + 2 ;
+EXPECT
+
+########
+
+$^W = $a ;
+EXPECT
+
+########
+
+sub fred {}
+$^W = fred() ;
+EXPECT
+
+########
+
+sub fred { my $b ; chop $b ;}
+{ local $^W = 0 ;
+  fred() ;
+}
+EXPECT
+
+########
+
+sub fred { my $b ; chop $b ;}
+{ local $^W = 1 ;
+  fred() ;
+}
+EXPECT
+Use of uninitialized value in scalar chop at - line 2.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/2use b/gnu/usr.bin/perl/t/lib/warnings/2use
new file mode 100644
index 00000000000..b700ef70dc0
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/2use
@@ -0,0 +1,354 @@
+Check lexical warnings functionality
+
+TODO
+  check that the warning hierarchy works.
+
+__END__
+
+#  check illegal category is caught
+use warnings 'this-should-never-be-a-warning-category' ;
+EXPECT
+Unknown warnings category 'this-should-never-be-a-warning-category' at - line 3
+BEGIN failed--compilation aborted at - line 3.
+########
+
+# Check compile time scope of pragma
+use warnings 'syntax' ;
+{
+    no warnings ;
+    my $a =+ 1 ;
+}
+my $a =+ 1 ;
+EXPECT
+Reversed += operator at - line 8.
+########
+
+# Check compile time scope of pragma
+no warnings;
+{
+    use warnings 'syntax' ;
+    my $a =+ 1 ;
+}
+my $a =+ 1 ;
+EXPECT
+Reversed += operator at - line 6.
+########
+
+# Check runtime scope of pragma
+use warnings 'uninitialized' ;
+{
+    no warnings ;
+    my $b ; chop $b ;
+}
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 8.
+########
+
+# Check runtime scope of pragma
+no warnings ;
+{
+    use warnings 'uninitialized' ;
+    my $b ; chop $b ;
+}
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 6.
+########
+
+# Check runtime scope of pragma
+no warnings ;
+{
+    use warnings 'uninitialized' ;
+    $a = sub { my $b ; chop $b ; }
+}
+&$a ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 6.
+########
+
+use warnings 'syntax' ;
+my $a =+ 1 ;
+EXPECT
+Reversed += operator at - line 3.
+########
+
+--FILE-- abc
+my $a =+ 1 ;
+1;
+--FILE-- 
+use warnings 'syntax' ;
+require "./abc";
+EXPECT
+
+########
+
+--FILE-- abc
+use warnings 'syntax' ;
+1;
+--FILE-- 
+require "./abc";
+my $a =+ 1 ;
+EXPECT
+
+########
+
+--FILE-- abc
+use warnings 'syntax' ;
+my $a =+ 1 ;
+1;
+--FILE-- 
+use warnings 'uninitialized' ;
+require "./abc";
+my $a ; chop $a ;
+EXPECT
+Reversed += operator at ./abc line 2.
+Use of uninitialized value in scalar chop at - line 3.
+########
+
+--FILE-- abc.pm
+use warnings 'syntax' ;
+my $a =+ 1 ;
+1;
+--FILE-- 
+use warnings 'uninitialized' ;
+use abc;
+my $a ; chop $a ;
+EXPECT
+Reversed += operator at abc.pm line 2.
+Use of uninitialized value in scalar chop at - line 3.
+########
+
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval {
+        my $b ; chop $b ;
+    }; print STDERR $@ ;
+    my $b ; chop $b ;
+}
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval {
+        use warnings 'uninitialized' ;
+        my $b ; chop $b ;
+    }; print STDERR $@ ;
+    my $b ; chop $b ;
+}
+EXPECT
+Use of uninitialized value in scalar chop at - line 8.
+########
+
+# 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 - line 7.
+Use of uninitialized value in scalar chop at - line 9.
+########
+
+# 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 - line 10.
+########
+
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval {
+        my $a =+ 1 ;
+    }; print STDERR $@ ;
+    my $a =+ 1 ;
+}
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval {
+        use warnings 'syntax' ;
+        my $a =+ 1 ;
+    }; print STDERR $@ ;
+    my $a =+ 1 ;
+}
+EXPECT
+Reversed += operator at - line 8.
+########
+
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'syntax' ;
+    eval {
+        my $a =+ 1 ;
+    }; print STDERR $@ ;
+    my $a =+ 1 ;
+}
+EXPECT
+Reversed += operator at - line 7.
+Reversed += operator at - line 9.
+########
+
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'syntax' ;
+    eval {
+        no warnings ;
+        my $a =+ 1 ;
+    }; print STDERR $@ ;
+    my $a =+ 1 ;
+}
+EXPECT
+Reversed += operator at - line 10.
+########
+
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval '
+        my $b ; chop $b ;
+    '; print STDERR $@ ;
+    my $b ; chop $b ;
+}
+EXPECT
+
+########
+
+# 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.
+########
+
+# 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.
+########
+
+# 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 - line 10.
+########
+
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval '
+        my $a =+ 1 ;
+    '; print STDERR $@ ;
+    my $a =+ 1 ;
+}
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval q[ 
+        use warnings 'syntax' ;
+        my $a =+ 1 ;
+    ]; print STDERR $@;
+    my $a =+ 1 ;
+}
+EXPECT
+Reversed += operator at (eval 1) line 3.
+########
+
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'syntax' ;
+    eval '
+        my $a =+ 1 ;
+    '; print STDERR $@;
+    my $a =+ 1 ;
+}
+EXPECT
+Reversed += operator at - line 9.
+Reversed += operator at (eval 1) line 2.
+########
+
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'syntax' ;
+    eval '
+        no warnings ;
+        my $a =+ 1 ;
+    '; print STDERR $@;
+    my $a =+ 1 ;
+}
+EXPECT
+Reversed += operator at - line 10.
+########
+
+# Check the additive nature of the pragma
+my $a =+ 1 ;
+my $a ; chop $a ;
+use warnings 'syntax' ;
+$a =+ 1 ;
+my $b ; chop $b ;
+use warnings 'uninitialized' ;
+my $c ; chop $c ;
+no warnings 'syntax' ;
+$a =+ 1 ;
+EXPECT
+Reversed += operator at - line 6.
+Use of uninitialized value in scalar chop at - line 9.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/3both b/gnu/usr.bin/perl/t/lib/warnings/3both
new file mode 100644
index 00000000000..a4d9ba806d6
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/3both
@@ -0,0 +1,266 @@
+Check interaction of $^W and lexical
+
+__END__
+
+# Check interaction of $^W and use warnings
+sub fred { 
+    use warnings ;
+    my $b ; 
+    chop $b ;
+}
+{ local $^W = 0 ;
+  fred() ;
+}
+
+EXPECT
+Use of uninitialized value in scalar chop at - line 6.
+########
+
+# Check interaction of $^W and use warnings
+sub fred { 
+    use warnings ;
+    my $b ; 
+    chop $b ;
+}
+{ $^W = 0 ;
+  fred() ;
+}
+
+EXPECT
+Use of uninitialized value in scalar chop at - line 6.
+########
+
+# Check interaction of $^W and use warnings
+sub fred { 
+    no warnings ;
+    my $b ; 
+    chop $b ;
+}
+{ local $^W = 1 ;
+  fred() ;
+}
+
+EXPECT
+
+########
+
+# Check interaction of $^W and use warnings
+sub fred { 
+    no warnings ;
+    my $b ; 
+    chop $b ;
+}
+{ $^W = 1 ;
+  fred() ;
+}
+
+EXPECT
+
+########
+
+# Check interaction of $^W and use warnings
+use warnings ;
+$^W = 1 ;
+my $b ; 
+chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 6.
+########
+
+# Check interaction of $^W and use warnings
+$^W = 1 ;
+use warnings ;
+my $b ; 
+chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 6.
+########
+
+# Check interaction of $^W and use warnings
+$^W = 1 ;
+no warnings ;
+my $b ; 
+chop $b ;
+EXPECT
+
+########
+
+# Check interaction of $^W and use warnings
+no warnings ;
+$^W = 1 ;
+my $b ; 
+chop $b ;
+EXPECT
+
+########
+-w
+# Check interaction of $^W and use warnings
+no warnings ;
+my $b ; 
+chop $b ;
+EXPECT
+
+########
+-w
+# Check interaction of $^W and use warnings
+use warnings ;
+my $b ; 
+chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 5.
+########
+
+# Check interaction of $^W and use warnings
+sub fred { 
+    use warnings ;
+    my $b ; 
+    chop $b ;
+}
+BEGIN {  $^W = 0 }
+fred() ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 6.
+########
+
+# Check interaction of $^W and use warnings
+sub fred { 
+    no warnings ;
+    my $b ; 
+    chop $b ;
+}
+BEGIN {  $^W = 1 }
+fred() ;
+
+EXPECT
+
+########
+
+# Check interaction of $^W and use warnings
+use warnings ;
+BEGIN {  $^W = 1 }
+my $b ; 
+chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 6.
+########
+
+# Check interaction of $^W and use warnings
+BEGIN {  $^W = 1 }
+use warnings ;
+my $b ; 
+chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 6.
+########
+
+# Check interaction of $^W and use warnings
+BEGIN {  $^W = 1 }
+no warnings ;
+my $b ; 
+chop $b ;
+EXPECT
+
+########
+
+# Check interaction of $^W and use warnings
+no warnings ;
+BEGIN {  $^W = 1 }
+my $b ; 
+chop $b ;
+EXPECT
+
+########
+
+# Check interaction of $^W and use warnings
+BEGIN {  $^W = 1 }
+{
+    no warnings ;
+    my $b ; 
+    chop $b ;
+}
+my $b ;
+chop $b ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 10.
+########
+
+# Check interaction of $^W and use warnings
+BEGIN {  $^W = 0 }
+{
+    use warnings ;
+    my $b ; 
+    chop $b ;
+}
+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 '
+        my $a =+ 1 ;
+    '; print STDERR $@ ;
+    my $a =+ 1 ;
+}
+EXPECT
+
diff --git a/gnu/usr.bin/perl/t/lib/warnings/4lint b/gnu/usr.bin/perl/t/lib/warnings/4lint
new file mode 100644
index 00000000000..805bd98905e
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/4lint
@@ -0,0 +1,219 @@
+Check lint
+
+__END__
+-W
+# lint: check compile time $^W is zapped
+BEGIN { $^W = 0 ;}
+$a = 1 ;
+$a =+ 1 ;
+close STDIN ; print STDIN "abc" ;
+EXPECT
+Reversed += operator at - line 5.
+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 STDIN at - line 4.
+########
+-W
+# lint: check runtime $^W is zapped
+{
+  $^W = 0 ;
+  close STDIN ; print STDIN "abc" ;
+}
+EXPECT
+print() on closed filehandle STDIN at - line 5.
+########
+-W
+# lint: check "no warnings" is zapped
+no warnings ;
+$a = 1 ;
+$a =+ 1 ;
+close STDIN ; print STDIN "abc" ;
+EXPECT
+Reversed += operator at - line 5.
+print() on closed filehandle STDIN at - line 6.
+########
+-W
+# lint: check "no warnings" is zapped
+{
+  no warnings ;
+  close STDIN ; print STDIN "abc" ;
+}
+EXPECT
+print() on closed filehandle STDIN at - line 5.
+########
+-Ww
+# lint: check combination of -w and -W
+{
+  $^W = 0 ;
+  close STDIN ; print STDIN "abc" ;
+}
+EXPECT
+print() on closed filehandle STDIN at - line 5.
+########
+-W
+--FILE-- abc.pm
+package abc;
+no warnings 'syntax' ;
+my $a = 0;
+$a =+ 1 ;
+1;
+--FILE-- 
+no warnings 'uninitialized' ;
+use abc;
+my $a ; chop $a ;
+EXPECT
+Reversed += operator at abc.pm line 4.
+Use of uninitialized value in scalar chop at - line 3.
+########
+-W
+--FILE-- abc
+package abc;
+no warnings 'syntax' ;
+my $a = 0;
+$a =+ 1 ;
+1;
+--FILE-- 
+no warnings 'uninitialized' ;
+require "./abc";
+my $a ; chop $a ;
+EXPECT
+Reversed += operator at ./abc line 4.
+Use of uninitialized value in scalar chop at - line 3.
+########
+-W
+--FILE-- abc.pm
+package abc;
+BEGIN {$^W = 0}
+my $a = 0 ;
+$a =+ 1 ;
+1;
+--FILE-- 
+$^W = 0 ;
+use abc;
+my $a ; chop $a ;
+EXPECT
+Reversed += operator at abc.pm line 4.
+Use of uninitialized value in scalar chop at - line 3.
+########
+-W
+--FILE-- abc
+BEGIN {$^W = 0}
+my $a = 0 ;
+$a =+ 1 ;
+1;
+--FILE-- 
+$^W = 0 ;
+require "./abc";
+my $a ; chop $a ;
+EXPECT
+Reversed += operator 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 'syntax' ;
+        $a =+ 1 ;
+    ]; print STDERR $@;
+    $a =+ 1 ;
+}
+EXPECT
+Reversed += operator at - line 11.
+Reversed += operator at (eval 1) line 3.
+########
+-W
+# Check scope of pragma with eval
+no warnings;
+{
+    my $a = "1"; my $b = "2";
+    use warnings 'syntax' ;
+    eval '
+        $a =+ 1 ;
+    '; print STDERR $@;
+    $a =+ 1 ;
+}
+EXPECT
+Reversed += operator at - line 10.
+Reversed += operator at (eval 1) line 2.
+########
+-W
+# Check scope of pragma with eval
+no warnings;
+{
+    my $a = "1"; my $b = "2";
+    use warnings 'syntax' ;
+    eval '
+        no warnings ;
+        $a =+ 1 ;
+    '; print STDERR $@;
+    $a =+ 1 ;
+}
+EXPECT
+Reversed += operator at - line 11.
+Reversed += operator at (eval 1) line 3.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/5nolint b/gnu/usr.bin/perl/t/lib/warnings/5nolint
new file mode 100644
index 00000000000..56158a20bef
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/5nolint
@@ -0,0 +1,204 @@
+syntax anti-lint
+
+__END__
+-X
+# nolint: check compile time $^W is zapped
+BEGIN { $^W = 1 ;}
+$a = $b = 1 ;
+$a =+ 1 ;
+close STDIN ; print STDIN "abc" ;
+EXPECT
+########
+-X
+# nolint: check runtime $^W is zapped
+$^W = 1 ;
+close STDIN ; print STDIN "abc" ;
+EXPECT
+########
+-X
+# nolint: check runtime $^W is zapped
+{
+  $^W = 1 ;
+  close STDIN ; print STDIN "abc" ;
+}
+EXPECT
+########
+-X
+# nolint: check "no warnings" is zapped
+use warnings ;
+$a = $b = 1 ;
+$a =+ 1 ;
+close STDIN ; print STDIN "abc" ;
+EXPECT
+########
+-X
+# nolint: check "no warnings" is zapped
+{
+  use warnings ;
+  close STDIN ; print STDIN "abc" ;
+}
+EXPECT
+########
+-Xw
+# nolint: check combination of -w and -X
+{
+  $^W = 1 ;
+  close STDIN ; print STDIN "abc" ;
+}
+EXPECT
+########
+-X
+--FILE-- abc.pm
+use warnings 'syntax' ;
+my $a = 0;
+$a =+ 1 ;
+1;
+--FILE-- 
+use warnings 'uninitialized' ;
+use abc;
+my $a ; chop $a ;
+EXPECT
+########
+-X
+--FILE-- abc
+use warnings 'syntax' ;
+my $a = 0;
+$a =+ 1 ;
+1;
+--FILE-- 
+use warnings 'uninitialized' ;
+require "./abc";
+my $a ; chop $a ;
+EXPECT
+########
+-X
+--FILE-- abc.pm
+BEGIN {$^W = 1}
+my ($a, $b) = (0,0);
+$a =+ 1 ;
+1;
+--FILE-- 
+$^W = 1 ;
+use abc;
+my $a ; chop $a ;
+EXPECT
+########
+-X
+--FILE-- abc
+BEGIN {$^W = 1}
+my ($a, $b) = (0,0);
+$a =+ 1 ;
+1;
+--FILE-- 
+$^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 '
+        my $a =+ 1 ;
+    '; print STDERR $@ ;
+    my $a =+ 1 ;
+}
+EXPECT
+
+########
+-X
+# Check scope of pragma with eval
+use warnings;
+{
+    no warnings ;
+    eval q[ 
+        use warnings 'syntax' ;
+        my $a =+ 1 ;
+    ]; print STDERR $@;
+    my $a =+ 1 ;
+}
+EXPECT
+
+########
+-X
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'syntax' ;
+    eval '
+        my $a =+ 1 ;
+    '; print STDERR $@;
+    my $a =+ 1 ;
+}
+EXPECT
+
+########
+-X
+# Check scope of pragma with eval
+no warnings;
+{
+    use warnings 'syntax' ;
+    eval '
+        no warnings ;
+        my $a =+ 1 ;
+    '; print STDERR $@;
+    my $a =+ 1 ;
+}
+EXPECT
+
diff --git a/gnu/usr.bin/perl/t/lib/warnings/6default b/gnu/usr.bin/perl/t/lib/warnings/6default
new file mode 100644
index 00000000000..a8aafeeb225
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/6default
@@ -0,0 +1,121 @@
+Check default warnings
+
+__END__
+# default warnings should be displayed if you don't add anything
+# optional shouldn't
+my $a = oct "7777777777777777777777777777777777779" ;
+EXPECT
+Integer overflow in octal number at - line 3.
+########
+# no warnings should be displayed 
+no warnings ;
+my $a = oct "7777777777777777777777777777777777778" ;
+EXPECT
+########
+# all warnings should be displayed 
+use warnings ;
+my $a = oct "7777777777777777777777777777777777778" ;
+EXPECT
+Integer overflow in octal number at - line 3.
+Illegal octal digit '8' ignored at - line 3.
+Octal number > 037777777777 non-portable at - line 3.
+########
+# check scope
+use warnings ;
+my $a = oct "7777777777777777777777777777777777778" ;
+{
+    no warnings ;
+    my $a = oct "7777777777777777777777777777777777778" ;
+}    
+my $c = oct "7777777777777777777777777777777777778" ;
+EXPECT
+Integer overflow in octal number at - line 3.
+Illegal octal digit '8' ignored at - line 3.
+Octal number > 037777777777 non-portable at - line 3.
+Integer overflow in octal number at - line 8.
+Illegal octal digit '8' ignored at - line 8.
+Octal number > 037777777777 non-portable at - line 8.
+########
+# all warnings should be displayed 
+use warnings ;
+my $a = oct "0xfffffffffffffffffg" ;
+EXPECT
+Integer overflow in hexadecimal number at - line 3.
+Illegal hexadecimal digit 'g' ignored at - line 3.
+Hexadecimal number > 0xffffffff non-portable at - line 3.
+########
+# all warnings should be displayed 
+use warnings ;
+my $a = oct "0b111111111111111111111111111111111111111111111111111111111111111112";
+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/gnu/usr.bin/perl/t/lib/warnings/7fatal b/gnu/usr.bin/perl/t/lib/warnings/7fatal
new file mode 100644
index 00000000000..a3e70f8d50f
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/7fatal
@@ -0,0 +1,426 @@
+Check FATAL functionality
+
+__END__
+
+# Check compile time warning
+use warnings FATAL => 'syntax' ;
+{
+    no warnings ;
+    $a =+ 1 ;
+}
+$a =+ 1 ;
+print STDERR "The End.\n" ;
+EXPECT
+Reversed += operator at - line 8.
+########
+
+# Check compile time warning
+use warnings FATAL => 'all' ;
+{
+    no warnings ;
+    my $a =+ 1 ;
+}
+my $a =+ 1 ;
+print STDERR "The End.\n" ;
+EXPECT
+Reversed += operator at - line 8.
+########
+
+# Check runtime scope of pragma
+use warnings FATAL => 'uninitialized' ;
+{
+    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
+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' ;
+    $a = sub { my $b ; chop $b ; }
+}
+&$a ;
+print STDERR "The End.\n" ;
+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
+$a =+ 1 ;
+1;
+--FILE-- 
+use warnings FATAL => 'syntax' ;
+require "./abc";
+EXPECT
+
+########
+
+--FILE-- abc
+use warnings FATAL => 'syntax' ;
+1;
+--FILE-- 
+require "./abc";
+$a =+ 1 ;
+EXPECT
+
+########
+
+--FILE-- abc
+use warnings 'syntax' ;
+$a =+ 1 ;
+1;
+--FILE-- 
+use warnings FATAL => 'uninitialized' ;
+require "./abc";
+my $a ; chop $a ;
+print STDERR "The End.\n" ;
+EXPECT
+Reversed += operator at ./abc line 2.
+Use of uninitialized value in scalar chop at - line 3.
+########
+
+--FILE-- abc.pm
+use warnings 'syntax' ;
+$a =+ 1 ;
+1;
+--FILE-- 
+use warnings FATAL => 'uninitialized' ;
+use abc;
+my $a ; chop $a ;
+print STDERR "The End.\n" ;
+EXPECT
+Reversed += operator at abc.pm line 2.
+Use of uninitialized value in scalar chop at - line 3.
+########
+
+# Check scope of pragma with eval
+no warnings ;
+eval {
+    use warnings FATAL => 'uninitialized' ;
+    my $b ; chop $b ;
+}; print STDERR "-- $@" ;
+my $b ; chop $b ;
+print STDERR "The End.\n" ;
+EXPECT
+-- Use of uninitialized value in scalar chop at - line 6.
+The End.
+########
+
+# Check scope of pragma with eval
+use warnings FATAL => 'uninitialized' ;
+eval {
+    my $b ; chop $b ;
+}; print STDERR "-- $@" ;
+my $b ; chop $b ;
+print STDERR "The End.\n" ;
+EXPECT
+-- Use of uninitialized value in scalar chop at - line 5.
+Use of uninitialized value in scalar chop at - line 7.
+########
+
+# Check scope of pragma with eval
+use warnings FATAL => 'uninitialized' ;
+eval {
+    no warnings ;
+    my $b ; chop $b ;
+}; print STDERR $@ ;
+my $b ; chop $b ;
+print STDERR "The End.\n" ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 8.
+########
+
+# Check scope of pragma with eval
+no warnings ;
+eval {
+    use warnings FATAL => 'syntax' ;
+    $a =+ 1 ;
+}; print STDERR "-- $@" ;
+$a =+ 1 ;
+print STDERR "The End.\n" ;
+EXPECT
+Reversed += operator at - line 6.
+########
+
+# Check scope of pragma with eval
+use warnings FATAL => 'syntax' ;
+eval {
+    $a =+ 1 ;
+}; print STDERR "-- $@" ;
+$a =+ 1 ;
+print STDERR "The End.\n" ;
+EXPECT
+Reversed += operator at - line 5.
+########
+
+# Check scope of pragma with eval
+use warnings FATAL => 'syntax' ;
+eval {
+    no warnings ;
+    $a =+ 1 ;
+}; print STDERR $@ ;
+$a =+ 1 ;
+print STDERR "The End.\n" ;
+EXPECT
+Reversed += operator at - line 8.
+########
+
+# Check scope of pragma with eval
+no warnings ;
+eval {
+    use warnings FATAL => 'syntax' ;
+}; print STDERR $@ ;
+$a =+ 1 ;
+print STDERR "The End.\n" ;
+EXPECT
+The End.
+########
+
+# Check scope of pragma with eval
+no warnings ;
+eval q[ 
+    use warnings FATAL => 'uninitialized' ;
+    my $b ; chop $b ;
+]; print STDERR "-- $@";
+my $b ; chop $b ;
+print STDERR "The End.\n" ;
+EXPECT
+-- Use of uninitialized value in scalar chop at (eval 1) line 3.
+The End.
+########
+
+# Check scope of pragma with eval
+use warnings FATAL => 'uninitialized' ;
+eval '
+    my $b ; chop $b ;
+'; print STDERR "-- $@" ;
+my $b ; chop $b ;
+print STDERR "The End.\n" ;
+EXPECT
+-- Use of uninitialized value in scalar chop at (eval 1) line 2.
+Use of uninitialized value in scalar chop at - line 7.
+########
+
+# Check scope of pragma with eval
+use warnings FATAL => 'uninitialized' ;
+eval '
+    no warnings ;
+    my $b ; chop $b ;
+'; print STDERR $@ ;
+my $b ; chop $b ;
+print STDERR "The End.\n" ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 8.
+########
+
+# Check scope of pragma with eval
+no warnings ;
+eval q[ 
+    use warnings FATAL => 'syntax' ;
+    $a =+ 1 ;
+]; print STDERR "-- $@";
+$a =+ 1 ;
+print STDERR "The End.\n" ;
+EXPECT
+-- Reversed += operator at (eval 1) line 3.
+The End.
+########
+
+# Check scope of pragma with eval
+use warnings FATAL => 'syntax' ;
+eval '
+    $a =+ 1 ;
+'; print STDERR "-- $@";
+print STDERR "The End.\n" ;
+EXPECT
+-- Reversed += operator at (eval 1) line 2.
+The End.
+########
+
+# Check scope of pragma with eval
+use warnings FATAL => 'syntax' ;
+eval '
+    no warnings ;
+    $a =+ 1 ;
+'; print STDERR "-- $@";
+$a =+ 1 ;
+print STDERR "The End.\n" ;
+EXPECT
+Reversed += operator 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.
+########
+
+use warnings FATAL => 'all';
+{
+    no warnings;
+    my $b ; chop $b;
+    {
+        use 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.
+Use of uninitialized value in scalar chop at - line 11.
+########
+
+use warnings FATAL => 'all';
+{
+    no warnings FATAL => 'all';
+    my $b ; chop $b;
+    {
+        use 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.
+Use of uninitialized value in scalar chop at - line 11.
+########
+
+use warnings FATAL => 'all';
+{
+    no warnings 'syntax';
+    {
+        use warnings ;
+        my $b ; chop $b;
+    }
+}
+my $b ; chop $b;
+print STDERR "The End.\n" ;
+EXPECT
+Use of uninitialized value in scalar chop at - line 7.
+########
+
+use warnings FATAL => 'syntax', NONFATAL => 'void' ;
+
+length "abc";
+print STDERR "The End.\n" ;
+EXPECT
+Useless use of length in void context at - line 4.
+The End.
+########
+
+use warnings FATAL => 'all', NONFATAL => 'void' ;
+
+length "abc";
+print STDERR "The End.\n" ;
+EXPECT
+Useless use of length in void context at - line 4.
+The End.
+########
+
+use warnings FATAL => 'all', NONFATAL => 'void' ;
+
+my $a ; chomp $a;
+length "abc";
+print STDERR "The End.\n" ;
+EXPECT
+Useless use of length in void context at - line 5.
+Use of uninitialized value in scalar chomp at - line 4.
+########
+
+use warnings FATAL => 'void', NONFATAL => 'void' ;
+
+length "abc";
+print STDERR "The End.\n" ;
+EXPECT
+Useless use of length in void context at - line 4.
+The End.
+########
+
+use warnings NONFATAL => 'void', FATAL => 'void' ;
+
+length "abc";
+print STDERR "The End.\n" ;
+EXPECT
+Useless use of length in void context at - line 4.
+########
+
+use warnings FATAL => 'all', NONFATAL => 'io';
+no warnings 'once';
+
+open(F, "<true\ncd");
+close "fred" ;
+print STDERR "The End.\n" ;
+EXPECT
+Unsuccessful open on filename containing newline at - line 5.
+close() on unopened filehandle fred at - line 6.
+The End.
+########
+
+use warnings FATAL => 'all', NONFATAL => 'io', FATAL => 'unopened' ;
+no warnings 'once';
+
+open(F, "<true\ncd");
+close "fred" ;
+print STDERR "The End.\n" ;
+EXPECT
+Unsuccessful open on filename containing newline at - line 5.
+close() on unopened filehandle fred at - line 6.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/8signal b/gnu/usr.bin/perl/t/lib/warnings/8signal
new file mode 100644
index 00000000000..cc1b9d926d7
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/8signal
@@ -0,0 +1,18 @@
+Check interaction of __WARN__, __DIE__ & lexical Warnings
+
+TODO
+
+__END__
+# 8signal
+BEGIN { $| = 1; $SIG{__WARN__} = sub { print "WARN -- @_" } }
+BEGIN { $SIG{__DIE__}  = sub { print "DIE -- @_" } }
+$a =+ 1 ;
+use warnings qw(syntax) ;
+$a =+ 1 ;
+use warnings FATAL => qw(syntax) ;
+$a =+ 1 ;
+print "The End.\n" ;
+EXPECT
+WARN -- Reversed += operator at - line 6.
+DIE -- Reversed += operator at - line 8.
+Reversed += operator at - line 8.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/9enabled b/gnu/usr.bin/perl/t/lib/warnings/9enabled
new file mode 100644
index 00000000000..99d32e54e81
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/9enabled
@@ -0,0 +1,1181 @@
+Check warnings::enabled & warnings::warn
+
+__END__
+
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+print "ok1\n" if ! warnings::enabled('all') ;
+print "ok2\n" if ! warnings::enabled("io") ;
+1;
+--FILE-- 
+no warnings;
+use abc ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+print "ok1\n" if !warnings::enabled('all') ;
+print "ok2\n" if warnings::enabled("syntax") ;
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'syntax' ;
+print "ok1\n" if   warnings::enabled('io') ;
+print "ok2\n" if ! warnings::enabled("syntax") ;
+1;
+--FILE-- 
+use warnings 'io' ;
+use abc ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc
+no warnings ;
+print "ok1\n" if !warnings::enabled('all') ;
+print "ok2\n" if warnings::enabled("syntax") ;
+1;
+--FILE-- 
+use warnings 'syntax' ;
+require "abc" ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc
+use warnings 'syntax' ;
+print "ok1\n" if ! warnings::enabled('all') ;
+print "ok2\n" if ! warnings::enabled("syntax") ;
+print "ok3\n" if   warnings::enabled("io") ;
+1;
+--FILE-- 
+use warnings 'io' ;
+require "abc" ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+sub check {
+  print "ok1\n" if !warnings::enabled('all') ;
+  print "ok2\n" if warnings::enabled("syntax") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+sub check {
+  print "ok1\n" if ! warnings::enabled('all') ;
+  print "ok2\n" if   warnings::enabled("syntax") ;
+  print "ok3\n" if ! warnings::enabled("io") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc
+package abc ;
+no warnings ;
+sub check {
+  print "ok1\n" if !warnings::enabled('all') ;
+  print "ok2\n" if warnings::enabled("syntax") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+require "abc" ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc
+package abc ;
+use warnings 'io' ;
+sub check {
+  print "ok1\n" if ! warnings::enabled('all') ;
+  print "ok2\n" if   warnings::enabled("syntax") ;
+  print "ok3\n" if ! warnings::enabled("io") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+require "abc" ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+print "ok1\n" if ! warnings::enabled('all') ;
+print "ok2\n" if ! warnings::enabled("io") ;
+1;
+--FILE-- def.pm
+package def;
+no warnings;
+use abc ;
+1;
+--FILE-- 
+use warnings;
+use def ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+print "ok1\n" if ! warnings::enabled('all') ;
+print "ok2\n" if warnings::enabled("syntax") ;
+print "ok3\n" if !warnings::enabled("io") ;
+1;
+--FILE-- def.pm
+use warnings 'syntax' ;
+print "ok4\n" if !warnings::enabled('all') ;
+print "ok5\n" if warnings::enabled("io") ;
+use abc ;
+1;
+--FILE--
+use warnings 'io' ;
+use def ;
+EXPECT
+ok1
+ok2
+ok3
+ok4
+ok5
+########
+
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+sub check {
+  print "ok1\n" if !warnings::enabled('all') ;
+  print "ok2\n" if warnings::enabled("syntax") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+eval { 
+  abc::check() ; 
+};
+print $@ ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+sub check {
+  print "ok1\n" if ! warnings::enabled('all') ;
+  print "ok2\n" if   warnings::enabled("syntax") ;
+  print "ok3\n" if ! warnings::enabled("io") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+eval { 
+  abc::check() ; 
+  } ;
+print $@ ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc
+package abc ;
+no warnings ;
+sub check {
+  print "ok1\n" if !warnings::enabled('all') ;
+  print "ok2\n" if warnings::enabled("syntax") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+require "abc" ;
+eval { 
+  abc::check() ; 
+  } ;
+print $@ ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc
+package abc ;
+use warnings 'io' ;
+sub check {
+  print "ok1\n" if !warnings::enabled('all') ;
+  print "ok2\n" if warnings::enabled("syntax") ;
+  print "ok3\n" if warnings::enabled("io") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+require "abc" ;
+eval { 
+  use warnings 'io' ; 
+  abc::check() ; 
+};
+abc::check() ; 
+print $@ ;
+EXPECT
+ok1
+ok2
+ok3
+ok1
+ok2
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+sub check {
+  print "ok1\n" if ! warnings::enabled('all') ;
+  print "ok2\n" if  warnings::enabled("syntax") ;
+  print "ok3\n" if ! warnings::enabled("io") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+sub fred { abc::check() }
+fred() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+sub check {
+  print "ok1\n" if  ! warnings::enabled('all') ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+sub fred { no warnings ; abc::check() }
+fred() ;
+EXPECT
+ok1
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'misc' ;
+sub check {
+  print "ok1\n" if  ! warnings::enabled('all') ;
+  print "ok2\n" if  warnings::enabled("syntax") ;
+  print "ok3\n" if  warnings::enabled("io") ;
+  print "ok4\n" if  ! warnings::enabled("misc") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+sub fred { use warnings 'io'  ; abc::check() }
+fred() ;
+EXPECT
+ok1
+ok2
+ok3
+ok4
+########
+
+# check warnings::warn
+use warnings ;
+eval { 
+    warnings::warn() 
+  } ;
+print $@ ;
+eval { 
+  warnings::warn("fred", "joe") 
+  } ;
+print $@ ;
+EXPECT
+Usage: warnings::warn([category,] 'message') at - line 5
+Unknown warnings category 'fred' at - line 9
+########
+
+# check warnings::warnif
+use warnings ;
+eval { 
+  warnings::warnif() 
+} ;
+print $@ ;
+eval { 
+  warnings::warnif("fred", "joe") 
+} ;
+print $@ ;
+EXPECT
+Usage: warnings::warnif([category,] 'message') at - line 5
+Unknown warnings category 'fred' at - line 9
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'misc' ;
+sub check { warnings::warn("io", "hello") }
+1;
+--FILE--
+use warnings "io" ;
+use abc;
+abc::check() ;
+EXPECT
+hello at - line 3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'misc' ;
+sub check { warnings::warn("misc", "hello") }
+1;
+--FILE--
+use warnings "io" ;
+use abc;
+abc::check() ;
+EXPECT
+hello at - line 3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'misc' ;
+sub check { warnings::warn("io", "hello") }
+1;
+--FILE--
+use warnings qw( FATAL deprecated ) ;
+use abc;
+eval { 
+    abc::check() ; 
+  } ;
+print "[[$@]]\n";
+EXPECT
+hello at - line 4
+[[]]
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'misc' ;
+sub check { warnings::warn("io", "hello") }
+1;
+--FILE--
+use warnings qw( FATAL io ) ;
+use abc;
+eval { 
+  abc::check() ; 
+} ;
+print "[[$@]]\n";
+EXPECT
+[[hello at - line 4
+]]
+########
+-W
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+print "ok1\n" if warnings::enabled("io") ;
+print "ok2\n" if warnings::enabled("all") ;
+1;
+--FILE-- 
+no warnings;
+use abc ;
+EXPECT
+ok1
+ok2
+########
+-X
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+print "ok1\n" if !warnings::enabled("io") ;
+print "ok2\n" if !warnings::enabled("all") ;
+1;
+--FILE-- 
+use warnings;
+use abc ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+sub check {
+  print "ok\n" if ! warnings::enabled() ;
+}
+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::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
+package abc ;
+use warnings 'io' ;
+use warnings::register ;
+sub check {
+  print "ok1\n" if  warnings::enabled ;
+  print "ok2\n" if  warnings::enabled("syntax") ;
+  print "ok3\n" if !warnings::enabled("io") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+use warnings 'abc' ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+use warnings::register ;
+sub check {
+  print "ok1\n" if !warnings::enabled ;
+  print "ok2\n" if  warnings::enabled("syntax") ;
+  print "ok3\n" if !warnings::enabled("io") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+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("syntax") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+use warnings 'abc' ;
+eval { abc::check() ; };
+print $@ ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+use warnings::register ;
+sub check {
+  print "ok1\n" if !warnings::enabled ;
+  print "ok2\n" if  warnings::enabled("syntax") ;
+  print "ok3\n" if !warnings::enabled("io") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+eval { abc::check() ; } ;
+print $@ ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+use warnings::register ;
+sub check {
+  print "ok1\n" if  warnings::enabled ;
+  print "ok2\n" if  warnings::enabled("syntax") ;
+  print "ok3\n" if !warnings::enabled("io") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+use warnings 'abc' ;
+sub fred { abc::check() }
+fred() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+use warnings::register ;
+sub check {
+  print "ok1\n" if  ! warnings::enabled ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+sub fred { no warnings ; abc::check() }
+fred() ;
+EXPECT
+ok1
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'misc' ;
+use warnings::register;
+sub check {
+  print "ok1\n" if  warnings::enabled ;
+  print "ok2\n" if  warnings::enabled("syntax") ;
+  print "ok3\n" if  warnings::enabled("io") ;
+  print "ok4\n" if  ! warnings::enabled("misc") ;
+}
+1;
+--FILE-- 
+use warnings 'syntax' ;
+use abc ;
+use warnings 'abc' ;
+sub fred { use warnings 'io'  ; abc::check() }
+fred() ;
+EXPECT
+ok1
+ok2
+ok3
+ok4
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'misc' ;
+use warnings::register;
+sub check { warnings::warn("hello") }
+1;
+--FILE--
+use abc;
+use warnings "abc" ;
+abc::check() ;
+EXPECT
+hello at - line 3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings::register;
+sub check { warnings::warn("hello") }
+1;
+--FILE--
+use abc;
+abc::check() ;
+EXPECT
+hello at - line 2
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings::register ;
+sub check { warnings::warn("hello") }
+1;
+--FILE--
+use abc;
+use warnings qw( FATAL deprecated ) ;
+eval {
+    abc::check() ; 
+  } ;
+print "[[$@]]\n";
+EXPECT
+hello at - line 4
+[[]]
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings::register ;
+sub check { warnings::warn("hello") }
+1;
+--FILE--
+use abc;
+use warnings qw( FATAL abc ) ;
+eval { 
+  abc::check() ; 
+  } ;
+print "[[$@]]\n";
+EXPECT
+[[hello at - line 4
+]]
+########
+-W
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+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-- 
+no warnings;
+use abc ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+-X
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+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-- 
+no warnings;
+use abc ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+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 warnings 'all';
+use abc ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+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 ;
+no warnings ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+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 ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+use warnings::register ;
+sub check { 
+  print "abc self" . (warnings::enabled() ? "" : " not") . " enabled\n" ;
+  print "abc def"  . (warnings::enabled('def') ? "" : " not") . " enabled\n" ;
+  print "abc all"  . (warnings::enabled('all') ? "" : " not") . " enabled\n" ;
+}
+1;
+--FILE-- def.pm
+package def ;
+use warnings "io" ;
+use warnings::register ;
+sub check { 
+  print "def self" . (warnings::enabled() ? "" : " not") . " enabled\n" ;
+  print "def abc"  . (warnings::enabled('abc') ? "" : " not") . " enabled\n" ;
+  print "def all"  . (warnings::enabled('all') ? "" : " not") . " enabled\n" ;
+}
+1;
+--FILE-- 
+use abc ;
+use def ;
+use warnings 'abc';
+abc::check() ;
+def::check() ;
+no warnings 'abc'  ;
+use warnings 'def'  ;
+abc::check() ;
+def::check() ;
+use warnings 'abc'  ;
+use warnings 'def'  ;
+abc::check() ;
+def::check() ;
+no warnings 'abc'  ;
+no warnings 'def'  ;
+abc::check() ;
+def::check() ;
+use warnings;
+abc::check() ;
+def::check() ;
+no warnings 'abc' ;
+abc::check() ;
+def::check() ;
+EXPECT
+abc self enabled
+abc def not enabled
+abc all not enabled
+def self not enabled
+def abc enabled
+def all not enabled
+abc self not enabled
+abc def enabled
+abc all not enabled
+def self enabled
+def abc not enabled
+def all not enabled
+abc self enabled
+abc def enabled
+abc all not enabled
+def self enabled
+def abc enabled
+def all not enabled
+abc self not enabled
+abc def not enabled
+abc all not enabled
+def self not enabled
+def abc not enabled
+def all not enabled
+abc self enabled
+abc def enabled
+abc all enabled
+def self enabled
+def abc enabled
+def all enabled
+abc self not enabled
+abc def enabled
+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
+my message 2 at abc.pm line 5
+my message 3 at abc.pm line 5
+########
+
+--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/gnu/usr.bin/perl/t/lib/warnings/av b/gnu/usr.bin/perl/t/lib/warnings/av
new file mode 100644
index 00000000000..79bd3b7600f
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/av
@@ -0,0 +1,9 @@
+  av.c	
+
+  Mandatory Warnings ALL TODO
+  ------------------
+  av_reify called on tied array		[av_reify]
+
+  Attempt to clear deleted array	[av_clear]
+  
+__END__
diff --git a/gnu/usr.bin/perl/t/lib/warnings/doio b/gnu/usr.bin/perl/t/lib/warnings/doio
new file mode 100644
index 00000000000..bb09aa85520
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/doio
@@ -0,0 +1,277 @@
+  doio.c	
+
+  Can't open bidirectional pipe		[Perl_do_open9]
+    open(F, "| true |");
+
+  Missing command in piped open		[Perl_do_open9]
+    open(F, "| ");
+
+  Missing command in piped open		[Perl_do_open9]
+    open(F, " |");
+
+  warn(warn_nl, "open");		[Perl_do_open9]
+    open(F, "true\ncd")
+
+  close() on unopened filehandle %s	[Perl_do_close]
+    $a = "fred";close("$a")
+
+  tell() on closed filehandle		[Perl_do_tell]
+    $a = "fred";$a = tell($a)
+
+  seek() on closed filehandle		[Perl_do_seek]
+    $a = "fred";$a = seek($a,1,1)
+
+  sysseek() on closed filehandle	[Perl_do_sysseek]
+    $a = "fred";$a = seek($a,1,1)
+
+  warn(warn_uninit);			[Perl_do_print]
+    print $a ;
+
+  -x on closed filehandle %s 		[Perl_my_stat]
+    close STDIN ; -x STDIN ;
+
+  warn(warn_nl, "stat");		[Perl_my_stat]
+    stat "ab\ncd"
+
+  warn(warn_nl, "lstat");		[Perl_my_lstat]
+    lstat "ab\ncd"
+
+  Use of -l on filehandle %s		[Perl_my_lstat]
+
+  Can't exec \"%s\": %s 		[Perl_do_aexec5]
+
+  Can't exec \"%s\": %s 		[Perl_do_exec3]
+
+  Filehandle %s opened only for output	[Perl_do_eof]
+	my $a = eof STDOUT
+
+  Mandatory Warnings ALL TODO
+  ------------------
+  Can't do inplace edit: %s is not a regular file	[Perl_nextargv]
+     edit a directory
+
+  Can't do inplace edit: %s would not be unique		[Perl_nextargv]
+  Can't rename %s to %s: %s, skipping file		[Perl_nextargv]
+  Can't rename %s to %s: %s, skipping file		[Perl_nextargv]
+  Can't remove %s: %s, skipping file			[Perl_nextargv]
+  Can't do inplace edit on %s: %s			[Perl_nextargv]
+  
+
+__END__
+# doio.c [Perl_do_open9]
+use warnings 'io' ;
+open(F, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|");
+close(F);
+no warnings 'io' ;
+open(G, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|");
+close(G);
+EXPECT
+Can't open bidirectional pipe at - line 3.
+########
+# doio.c [Perl_do_open9]
+use warnings 'io' ;
+open(F, "|      ");
+no warnings 'io' ;
+open(G, "|      ");
+EXPECT
+Missing command in piped open at - line 3.
+########
+# doio.c [Perl_do_open9]
+use warnings 'io' ;
+open(F, "      |");
+no warnings 'io' ;
+open(G, "      |");
+EXPECT
+Missing command in piped open at - line 3.
+########
+# doio.c [Perl_do_open9]
+use warnings 'io' ;
+open(F, "<true\ncd");
+no warnings 'io' ;
+open(G, "<true\ncd");
+EXPECT
+Unsuccessful open on filename containing newline at - line 3.
+########
+# doio.c [Perl_do_close] <<TODO
+use warnings 'unopened' ;
+close "fred" ;
+no warnings 'unopened' ;
+close "joe" ;
+EXPECT
+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' ;
+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; # 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 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' ;
+print $a ;
+no warnings 'uninitialized' ;
+print $b ;
+EXPECT
+Use of uninitialized value in print at - line 3.
+########
+# doio.c [Perl_my_stat Perl_my_lstat]
+use warnings 'io' ;
+stat "ab\ncd";
+lstat "ab\ncd";
+no warnings 'io' ;
+stat "ab\ncd";
+lstat "ab\ncd";
+EXPECT
+Unsuccessful stat on filename containing newline at - line 3.
+Unsuccessful stat on filename containing newline at - line 4.
+########
+# doio.c [Perl_my_stat]
+use warnings 'io';
+-l STDIN;
+-l $fh;
+open $fh, $0 or die "# $!";
+-l $fh;
+no warnings 'io';
+-l STDIN;
+-l $fh;
+close $fh;
+EXPECT
+Use of -l on filehandle STDIN at - line 3.
+Use of -l on filehandle $fh at - line 6.
+########
+# doio.c [Perl_do_aexec5]
+BEGIN {
+    if ($^O eq 'MacOS') {
+	print <<EOM;
+SKIPPED
+# no exec on Mac OS
+EOM
+	exit;
+    }
+}
+use warnings 'io' ;
+exec "lskdjfalksdjfdjfkls","" ;
+no warnings 'io' ;
+exec "lskdjfalksdjfdjfkls","" ;
+EXPECT
+OPTION regex
+Can't exec "lskdjfalksdjfdjfkls": .+
+########
+# doio.c [Perl_do_exec3]
+BEGIN {
+    if ($^O eq 'MacOS') {
+	print <<EOM;
+SKIPPED
+# no exec on Mac OS
+EOM
+	exit;
+    }
+}
+use warnings 'io' ;
+exec "lskdjfalksdjfdjfkls", "abc" ;
+no warnings 'io' ;
+exec "lskdjfalksdjfdjfkls", "abc" ;
+EXPECT
+OPTION regex
+Can't exec "lskdjfalksdjfdjfkls(:? abc)?": .+
+########
+# doio.c [win32_execvp]
+BEGIN {
+    if ($^O eq 'MacOS') {
+	print <<EOM;
+SKIPPED
+# no exec on Mac OS
+EOM
+	exit;
+    }
+}
+use warnings 'exec' ;
+exec $^X, "-e0" ;
+EXPECT
+########
+# doio.c [Perl_nextargv]
+$^W = 0 ;
+my $filename = "./temp.dir" ;
+mkdir $filename, 0777 
+  or die "Cannot create directory $filename: $!\n" ;
+{
+    local (@ARGV) = ($filename) ;
+    local ($^I) = "" ;
+    my $x = <> ;
+}
+{
+    no warnings 'inplace' ;
+    local (@ARGV) = ($filename) ;
+    local ($^I) = "" ;
+    my $x = <> ;
+}
+{
+    use warnings 'inplace' ;
+    local (@ARGV) = ($filename) ;
+    local ($^I) = "" ;
+    my $x = <> ;
+}
+rmdir $filename ;
+EXPECT
+Can't do inplace edit: ./temp.dir is not a regular file at - line 9.
+Can't do inplace edit: ./temp.dir is not a regular file at - line 21.
+
+########
+# doio.c [Perl_do_eof]
+use warnings 'io' ;
+my $a = eof STDOUT ;
+no warnings 'io' ;
+$a = eof STDOUT ;
+EXPECT
+Filehandle STDOUT opened only for output at - line 3.
+########
+# doio.c [Perl_do_openn]
+use Config;
+BEGIN {
+    if ($Config{useperlio}) {
+	print <<EOM;
+SKIPPED
+# warns only without perlio
+EOM
+	exit;
+    }
+}
+use warnings 'io';
+my $x = "foo";
+open FOO, '>', \$x;
+open BAR, '>&', \*STDOUT; # should not warn
+no warnings 'io';
+open FOO, '>', \$x;
+EXPECT
+Can't open a reference at - line 14.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/doop b/gnu/usr.bin/perl/t/lib/warnings/doop
new file mode 100644
index 00000000000..5803b445812
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/doop
@@ -0,0 +1,6 @@
+# doop.c
+use utf8 ;
+$_ = "\x80  \xff" ;
+chop ;
+EXPECT
+########
diff --git a/gnu/usr.bin/perl/t/lib/warnings/gv b/gnu/usr.bin/perl/t/lib/warnings/gv
new file mode 100644
index 00000000000..5ed4eca0180
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/gv
@@ -0,0 +1,54 @@
+  gv.c AOK
+
+     Can't locate package %s for @%s::ISA
+	@ISA = qw(Fred); joe()
+
+     Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated
+	sub Other::AUTOLOAD { 1 } sub Other::fred {}
+	@ISA = qw(Other) ;
+	fred() ;
+
+     Use of $# is deprecated
+     Use of $* is deprecated
+
+	$a = ${"#"} ;
+ 	$a = ${"*"} ;
+
+  Mandatory Warnings ALL TODO
+  ------------------
+
+    Had to create %s unexpectedly		[gv_fetchpv]
+    Attempt to free unreferenced glob pointers	[gp_free]
+    
+__END__
+# gv.c
+use warnings 'misc' ;
+@ISA = qw(Fred); joe()
+EXPECT
+Can't locate package Fred for @main::ISA at - line 3.
+Undefined subroutine &main::joe called at - line 3.
+########
+# gv.c
+no warnings 'misc' ;
+@ISA = qw(Fred); joe()
+EXPECT
+Undefined subroutine &main::joe called at - line 3.
+########
+# gv.c
+sub Other::AUTOLOAD { 1 } sub Other::fred {}
+@ISA = qw(Other) ;
+use warnings 'deprecated' ;
+fred() ;
+EXPECT
+Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5.
+########
+# gv.c
+use warnings 'deprecated' ;
+$a = ${"#"};
+$a = ${"*"};
+no warnings 'deprecated' ;
+$a = ${"#"};
+$a = ${"*"};
+EXPECT
+Use of $# is deprecated at - line 3.
+Use of $* is deprecated at - line 4.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/hv b/gnu/usr.bin/perl/t/lib/warnings/hv
new file mode 100644
index 00000000000..c9eec028f14
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/hv
@@ -0,0 +1,8 @@
+  hv.c 
+
+
+  Mandatory Warnings ALL TODO
+  ------------------
+    Attempt to free non-existent shared string	[unsharepvn]
+
+__END__
diff --git a/gnu/usr.bin/perl/t/lib/warnings/malloc b/gnu/usr.bin/perl/t/lib/warnings/malloc
new file mode 100644
index 00000000000..2f8b096a518
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/malloc
@@ -0,0 +1,9 @@
+  malloc.c 
+
+
+  Mandatory Warnings ALL TODO
+  ------------------
+    %s free() ignored		[Perl_mfree]
+    %s", "Bad free() ignored	[Perl_mfree]
+
+__END__
diff --git a/gnu/usr.bin/perl/t/lib/warnings/mg b/gnu/usr.bin/perl/t/lib/warnings/mg
new file mode 100644
index 00000000000..f7c3ebf435c
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/mg
@@ -0,0 +1,57 @@
+  mg.c	AOK
+
+  No such signal: SIG%s
+    $SIG{FRED} = sub {}
+
+  SIG%s handler \"%s\" not defined.
+    $SIG{"INT"} = "ok3"; kill "INT",$$;
+
+  Mandatory Warnings TODO
+  ------------------
+  Can't break at that line	[magic_setdbline]
+
+__END__
+# mg.c
+use warnings 'signal' ;
+$SIG{FRED} = sub {};
+EXPECT
+No such signal: SIGFRED at - line 3.
+########
+# mg.c
+no warnings 'signal' ;
+$SIG{FRED} = sub {};
+EXPECT
+
+########
+# mg.c
+use warnings 'signal' ;
+if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' || $^O eq 'MacOS') {
+    print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit;
+}
+$|=1;
+$SIG{"INT"} = "fred"; kill "INT",$$;
+EXPECT
+SIGINT handler "fred" not defined.
+########
+# mg.c
+no warnings 'signal' ;
+if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' || $^O eq 'MacOS') {
+    print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit;
+}
+$|=1;
+$SIG{"INT"} = "fred"; kill "INT",$$;
+EXPECT
+
+########
+# mg.c
+use warnings 'uninitialized';
+'foo' =~ /(foo)/;
+length $3;
+EXPECT
+Use of uninitialized value in length at - line 4.
+########
+# mg.c
+use warnings 'uninitialized';
+length $3;
+EXPECT
+Use of uninitialized value in length at - line 3.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/op b/gnu/usr.bin/perl/t/lib/warnings/op
new file mode 100644
index 00000000000..011fd17beb3
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/op
@@ -0,0 +1,986 @@
+  op.c		AOK
+
+     "my" variable %s masks earlier declaration in same scope
+	my $x;
+	my $x ;
+
+     Variable "%s" may be unavailable 
+	sub x {
+      	    my $x;
+      	    sub y {
+         	$x
+      	    }
+   	}
+
+     Variable "%s" will not stay shared 
+	sub x {
+      	    my $x;
+      	    sub y {
+         	sub { $x }
+      	    }
+   	}
+
+     Found = in conditional, should be ==
+	1 if $a = 1 ;
+
+     Use of implicit split to @_ is deprecated
+	split ;
+
+     Use of implicit split to @_ is deprecated
+	$a = split ;
+
+     Useless use of time in void context
+     Useless use of a variable in void context
+     Useless use of a constant in void context
+	time ;
+	$a ;
+	"abc"
+
+     Useless use of sort in scalar context
+	my $x = sort (2,1,3);
+
+     Applying %s to %s will act on scalar(%s)
+	my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
+	@a =~ /abc/ ;
+	@a =~ s/a/b/ ;
+	@a =~ tr/a/b/ ;
+	@$b =~ /abc/ ;
+	@$b =~ s/a/b/ ;
+	@$b =~ tr/a/b/ ;
+	%a =~ /abc/ ;
+	%a =~ s/a/b/ ;
+	%a =~ tr/a/b/ ;
+	%$c =~ /abc/ ;
+	%$c =~ s/a/b/ ;
+	%$c =~ tr/a/b/ ;
+
+
+     Parentheses missing around "my" list at -e line 1.
+       my $a, $b = (1,2);
+ 
+     Parentheses missing around "local" list at -e line 1.
+       local $a, $b = (1,2);
+ 
+     Bareword found in conditional at -e line 1.
+       use warnings 'bareword'; my $x = print(ABC || 1);
+ 
+     Value of %s may be \"0\"; use \"defined\" 
+	$x = 1 if $x = <FH> ;
+	$x = 1 while $x = <FH> ;
+
+     Subroutine fred redefined at -e line 1.
+       sub fred{1;} sub fred{1;}
+ 
+     Constant subroutine %s redefined 
+        sub fred() {1;} sub fred() {1;}
+ 
+     Format FRED redefined at /tmp/x line 5.
+       format FRED =
+       .
+       format FRED =
+       .
+ 
+     Array @%s missing the @ in argument %d of %s() 
+	push fred ;
+ 
+     Hash %%%s missing the %% in argument %d of %s() 
+	keys joe ;
+ 
+     Statement unlikely to be reached
+     	(Maybe you meant system() when you said exec()?
+ 	exec "true" ; my $a
+
+     defined(@array) is deprecated
+     	(Maybe you should just omit the defined()?)
+	my @a ; defined @a ;
+	defined (@a = (1,2,3)) ;
+
+     defined(%hash) is deprecated
+     	(Maybe you should just omit the defined()?)
+	my %h ; defined %h ;
+    
+     /---/ should probably be written as "---"
+        join(/---/, @foo);
+
+    %s() called too early to check prototype		[Perl_peep]
+        fred() ; sub fred ($$) {}
+
+
+     Use of "package" with no arguments is deprecated
+	package;
+
+    Package `%s' not found (did you use the incorrect case?)
+
+    Use of /g modifier is meaningless in split
+
+    Mandatory Warnings 
+    ------------------
+    Prototype mismatch:		[cv_ckproto]
+        sub fred() ;
+        sub fred($) {}
+
+    %s never introduced		[pad_leavemy]	TODO
+    Runaway prototype		[newSUB]	TODO
+    oops: oopsAV		[oopsAV]	TODO
+    oops: oopsHV		[oopsHV]	TODO
+    
+
+__END__
+# op.c
+use warnings 'misc' ;
+my $x ;
+my $x ;
+my $y = my $y ;
+no warnings 'misc' ;
+my $x ;
+my $y ;
+EXPECT
+"my" variable $x masks earlier declaration in same scope at - line 4.
+"my" variable $y masks earlier declaration in same statement at - line 5.
+########
+# op.c
+use warnings 'closure' ;
+sub x {
+      my $x;
+      sub y {
+         $x
+      }
+   }
+EXPECT
+Variable "$x" will not stay shared at - line 7.
+########
+# op.c
+no warnings 'closure' ;
+sub x {
+      my $x;
+      sub y {
+         $x
+      }
+   }
+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 }
+      }
+   }
+EXPECT
+Variable "$x" may be unavailable at - line 6.
+########
+# op.c
+no warnings 'closure' ;
+sub x {
+      my $x;
+      sub y {
+         sub { $x }
+      }
+   }
+EXPECT
+
+########
+# op.c
+use warnings 'syntax' ;
+1 if $a = 1 ;
+no warnings 'syntax' ;
+1 if $a = 1 ;
+EXPECT
+Found = in conditional, should be == at - line 3.
+########
+# op.c
+use warnings 'deprecated' ;
+split ;
+no warnings 'deprecated' ;
+split ;
+EXPECT
+Use of implicit split to @_ is deprecated at - line 3.
+########
+# op.c
+use warnings 'deprecated' ;
+$a = split ;
+no warnings 'deprecated' ;
+$a = split ;
+EXPECT
+Use of implicit split to @_ is deprecated at - line 3.
+########
+# op.c
+use warnings 'deprecated';
+my (@foo, %foo);
+%main::foo->{"bar"};
+%foo->{"bar"};
+@main::foo->[23];
+@foo->[23];
+$main::foo = {}; %$main::foo->{"bar"};
+$foo = {}; %$foo->{"bar"};
+$main::foo = []; @$main::foo->[34];
+$foo = []; @$foo->[34];
+no warnings 'deprecated';
+%main::foo->{"bar"};
+%foo->{"bar"};
+@main::foo->[23];
+@foo->[23];
+$main::foo = {}; %$main::foo->{"bar"};
+$foo = {}; %$foo->{"bar"};
+$main::foo = []; @$main::foo->[34];
+$foo = []; @$foo->[34];
+EXPECT
+Using a hash as a reference is deprecated at - line 4.
+Using a hash as a reference is deprecated at - line 5.
+Using an array as a reference is deprecated at - line 6.
+Using an array as a reference is deprecated at - line 7.
+Using a hash as a reference is deprecated at - line 8.
+Using a hash as a reference is deprecated at - line 9.
+Using an array as a reference is deprecated at - line 10.
+Using an array as a reference is deprecated at - line 11.
+########
+# op.c
+use warnings 'void' ; close STDIN ;
+1 x 3 ;			# OP_REPEAT
+			# OP_GVSV
+wantarray ; 		# OP_WANTARRAY
+			# OP_GV
+			# OP_PADSV
+			# OP_PADAV
+			# OP_PADHV
+			# OP_PADANY
+			# OP_AV2ARYLEN
+ref ;			# OP_REF
+\@a ;			# OP_REFGEN
+\$a ;			# OP_SREFGEN
+defined $a ;		# OP_DEFINED
+hex $a ;		# OP_HEX
+oct $a ;		# OP_OCT
+length $a ;		# OP_LENGTH
+substr $a,1 ;		# OP_SUBSTR
+vec $a,1,2 ;		# OP_VEC
+index $a,1,2 ;		# OP_INDEX
+rindex $a,1,2 ;		# OP_RINDEX
+sprintf $a ;		# OP_SPRINTF
+$a[0] ;			# OP_AELEM
+			# OP_AELEMFAST
+@a[0] ;			# OP_ASLICE
+#values %a ;		# OP_VALUES
+#keys %a ;		# OP_KEYS
+$a{0} ;			# OP_HELEM
+@a{0} ;			# OP_HSLICE
+unpack "a", "a" ;	# OP_UNPACK
+pack $a,"" ;		# OP_PACK
+join "" ;		# OP_JOIN
+(@a)[0,1] ;		# OP_LSLICE
+			# OP_ANONLIST
+			# OP_ANONHASH
+sort(1,2) ;		# OP_SORT
+reverse(1,2) ;		# OP_REVERSE
+			# OP_RANGE
+			# OP_FLIP
+(1 ..2) ;		# OP_FLOP
+caller ;		# OP_CALLER
+fileno STDIN ;		# OP_FILENO
+eof STDIN ;		# OP_EOF
+tell STDIN ;		# OP_TELL
+readlink 1;		# OP_READLINK
+time ;			# OP_TIME
+localtime ;		# OP_LOCALTIME
+gmtime ;		# OP_GMTIME
+eval { getgrnam 1 };	# OP_GGRNAM
+eval { getgrgid 1 };	# OP_GGRGID
+eval { getpwnam 1 };	# OP_GPWNAM
+eval { getpwuid 1 };	# OP_GPWUID
+EXPECT
+Useless use of repeat (x) in void context at - line 3.
+Useless use of wantarray in void context at - line 5.
+Useless use of reference-type operator in void context at - line 12.
+Useless use of reference constructor in void context at - line 13.
+Useless use of single ref constructor in void context at - line 14.
+Useless use of defined operator in void context at - line 15.
+Useless use of hex in void context at - line 16.
+Useless use of oct in void context at - line 17.
+Useless use of length in void context at - line 18.
+Useless use of substr in void context at - line 19.
+Useless use of vec in void context at - line 20.
+Useless use of index in void context at - line 21.
+Useless use of rindex in void context at - line 22.
+Useless use of sprintf in void context at - line 23.
+Useless use of array element in void context at - line 24.
+Useless use of array slice in void context at - line 26.
+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 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.
+Useless use of range (or flop) in void context at - line 41.
+Useless use of caller in void context at - line 42.
+Useless use of fileno in void context at - line 43.
+Useless use of eof in void context at - line 44.
+Useless use of tell in void context at - line 45.
+Useless use of readlink in void context at - line 46.
+Useless use of time in void context at - line 47.
+Useless use of localtime in void context at - line 48.
+Useless use of gmtime in void context at - line 49.
+Useless use of getgrnam in void context at - line 50.
+Useless use of getgrgid in void context at - line 51.
+Useless use of getpwnam in void context at - line 52.
+Useless use of getpwuid in void context at - line 53.
+########
+# op.c
+use warnings 'void' ; close STDIN ;
+my $x = sort (2,1,3);
+no warnings 'void' ;
+$x = sort (2,1,3);
+EXPECT
+Useless use of sort in scalar context at - line 3.
+########
+# op.c
+no warnings 'void' ; close STDIN ;
+1 x 3 ;			# OP_REPEAT
+			# OP_GVSV
+wantarray ; 		# OP_WANTARRAY
+			# OP_GV
+			# OP_PADSV
+			# OP_PADAV
+			# OP_PADHV
+			# OP_PADANY
+			# OP_AV2ARYLEN
+ref ;			# OP_REF
+\@a ;			# OP_REFGEN
+\$a ;			# OP_SREFGEN
+defined $a ;		# OP_DEFINED
+hex $a ;		# OP_HEX
+oct $a ;		# OP_OCT
+length $a ;		# OP_LENGTH
+substr $a,1 ;		# OP_SUBSTR
+vec $a,1,2 ;		# OP_VEC
+index $a,1,2 ;		# OP_INDEX
+rindex $a,1,2 ;		# OP_RINDEX
+sprintf $a ;		# OP_SPRINTF
+$a[0] ;			# OP_AELEM
+			# OP_AELEMFAST
+@a[0] ;			# OP_ASLICE
+#values %a ;		# OP_VALUES
+#keys %a ;		# OP_KEYS
+$a{0} ;			# OP_HELEM
+@a{0} ;			# OP_HSLICE
+unpack "a", "a" ;	# OP_UNPACK
+pack $a,"" ;		# OP_PACK
+join "" ;		# OP_JOIN
+(@a)[0,1] ;		# OP_LSLICE
+			# OP_ANONLIST
+			# OP_ANONHASH
+sort(1,2) ;		# OP_SORT
+reverse(1,2) ;		# OP_REVERSE
+			# OP_RANGE
+			# OP_FLIP
+(1 ..2) ;		# OP_FLOP
+caller ;		# OP_CALLER
+fileno STDIN ;		# OP_FILENO
+eof STDIN ;		# OP_EOF
+tell STDIN ;		# OP_TELL
+readlink 1;		# OP_READLINK
+time ;			# OP_TIME
+localtime ;		# OP_LOCALTIME
+gmtime ;		# OP_GMTIME
+eval { getgrnam 1 };	# OP_GGRNAM
+eval { getgrgid 1 };	# OP_GGRGID
+eval { getpwnam 1 };	# OP_GPWNAM
+eval { getpwuid 1 };	# OP_GPWUID
+EXPECT
+########
+# op.c
+use warnings 'void' ;
+for (@{[0]}) { "$_" }		# check warning isn't duplicated
+no warnings 'void' ;
+for (@{[0]}) { "$_" }		# check warning isn't duplicated
+EXPECT
+Useless use of string in void context at - line 3.
+########
+# op.c
+use warnings 'void' ;
+use Config ;
+BEGIN {
+    if ( ! $Config{d_telldir}) {
+        print <<EOM ;
+SKIPPED
+# telldir not present
+EOM
+        exit 
+    }
+}
+telldir 1 ;		# OP_TELLDIR
+no warnings 'void' ;
+telldir 1 ;		# OP_TELLDIR
+EXPECT
+Useless use of telldir in void context at - line 13.
+########
+# op.c
+use warnings 'void' ;
+use Config ;
+BEGIN {
+    if ( ! $Config{d_getppid}) {
+        print <<EOM ;
+SKIPPED
+# getppid not present
+EOM
+        exit 
+    }
+}
+getppid ;		# OP_GETPPID
+no warnings 'void' ;
+getppid ;		# OP_GETPPID
+EXPECT
+Useless use of getppid in void context at - line 13.
+########
+# op.c
+use warnings 'void' ;
+use Config ;
+BEGIN {
+    if ( ! $Config{d_getpgrp}) {
+        print <<EOM ;
+SKIPPED
+# getpgrp not present
+EOM
+        exit 
+    }
+}
+getpgrp ;		# OP_GETPGRP
+no warnings 'void' ;
+getpgrp ;		# OP_GETPGRP
+EXPECT
+Useless use of getpgrp in void context at - line 13.
+########
+# op.c
+use warnings 'void' ;
+use Config ;
+BEGIN {
+    if ( ! $Config{d_times}) {
+        print <<EOM ;
+SKIPPED
+# times not present
+EOM
+        exit 
+    }
+}
+times ;			# OP_TMS
+no warnings 'void' ;
+times ;			# OP_TMS
+EXPECT
+Useless use of times in void context at - line 13.
+########
+# op.c
+use warnings 'void' ;
+use Config ;
+BEGIN {
+    if ( ! $Config{d_getprior} or $^O eq 'os2') { # Locks before fixpak22
+        print <<EOM ;
+SKIPPED
+# getpriority not present
+EOM
+        exit 
+    }
+}
+getpriority 1,2;	# OP_GETPRIORITY
+no warnings 'void' ;
+getpriority 1,2;	# OP_GETPRIORITY
+EXPECT
+Useless use of getpriority in void context at - line 13.
+########
+# op.c
+use warnings 'void' ;
+use Config ;
+BEGIN {
+    if ( ! $Config{d_getlogin}) {
+        print <<EOM ;
+SKIPPED
+# getlogin not present
+EOM
+        exit 
+    }
+}
+getlogin ;			# OP_GETLOGIN
+no warnings 'void' ;
+getlogin ;			# OP_GETLOGIN
+EXPECT
+Useless use of getlogin in void context at - line 13.
+########
+# op.c
+use warnings 'void' ;
+use Config ; BEGIN {
+if ( ! $Config{d_socket}) {
+    print <<EOM ;
+SKIPPED
+# getsockname not present
+# getpeername not present
+# gethostbyname not present
+# gethostbyaddr not present
+# gethostent not present
+# getnetbyname not present
+# getnetbyaddr not present
+# getnetent not present
+# getprotobyname not present
+# getprotobynumber not present
+# getprotoent not present
+# getservbyname not present
+# getservbyport not present
+# getservent not present
+EOM
+    exit 
+} }
+getsockname STDIN ;	# OP_GETSOCKNAME
+getpeername STDIN ;	# OP_GETPEERNAME
+gethostbyname 1 ;	# OP_GHBYNAME
+gethostbyaddr 1,2;	# OP_GHBYADDR
+gethostent ;		# OP_GHOSTENT
+getnetbyname 1 ;	# OP_GNBYNAME
+getnetbyaddr 1,2 ;	# OP_GNBYADDR
+getnetent ;		# OP_GNETENT
+getprotobyname 1;	# OP_GPBYNAME
+getprotobynumber 1;	# OP_GPBYNUMBER
+getprotoent ;		# OP_GPROTOENT
+getservbyname 1,2;	# OP_GSBYNAME
+getservbyport 1,2;	# OP_GSBYPORT
+getservent ;		# OP_GSERVENT
+
+no warnings 'void' ;
+getsockname STDIN ;	# OP_GETSOCKNAME
+getpeername STDIN ;	# OP_GETPEERNAME
+gethostbyname 1 ;	# OP_GHBYNAME
+gethostbyaddr 1,2;	# OP_GHBYADDR
+gethostent ;		# OP_GHOSTENT
+getnetbyname 1 ;	# OP_GNBYNAME
+getnetbyaddr 1,2 ;	# OP_GNBYADDR
+getnetent ;		# OP_GNETENT
+getprotobyname 1;	# OP_GPBYNAME
+getprotobynumber 1;	# OP_GPBYNUMBER
+getprotoent ;		# OP_GPROTOENT
+getservbyname 1,2;	# OP_GSBYNAME
+getservbyport 1,2;	# OP_GSBYPORT
+getservent ;		# OP_GSERVENT
+INIT {
+   # some functions may not be there, so we exit without running
+   exit;
+}
+EXPECT
+Useless use of getsockname in void context at - line 24.
+Useless use of getpeername in void context at - line 25.
+Useless use of gethostbyname in void context at - line 26.
+Useless use of gethostbyaddr in void context at - line 27.
+Useless use of gethostent in void context at - line 28.
+Useless use of getnetbyname in void context at - line 29.
+Useless use of getnetbyaddr in void context at - line 30.
+Useless use of getnetent in void context at - line 31.
+Useless use of getprotobyname in void context at - line 32.
+Useless use of getprotobynumber in void context at - line 33.
+Useless use of getprotoent in void context at - line 34.
+Useless use of getservbyname in void context at - line 35.
+Useless use of getservbyport in void context at - line 36.
+Useless use of getservent in void context at - line 37.
+########
+# op.c
+use warnings 'void' ;
+*a ; # OP_RV2GV
+$a ; # OP_RV2SV
+@a ; # OP_RV2AV
+%a ; # OP_RV2HV
+no warnings 'void' ;
+*a ; # OP_RV2GV
+$a ; # OP_RV2SV
+@a ; # OP_RV2AV
+%a ; # OP_RV2HV
+EXPECT
+Useless use of a variable in void context at - line 3.
+Useless use of a variable in void context at - line 4.
+Useless use of a variable in void context at - line 5.
+Useless use of a variable in void context at - line 6.
+########
+# op.c
+use warnings 'void' ;
+"abc"; # OP_CONST
+7 ; # OP_CONST
+no warnings 'void' ;
+"abc"; # OP_CONST
+7 ; # OP_CONST
+EXPECT
+Useless use of a constant in void context at - line 3.
+Useless use of a constant in void context at - line 4.
+########
+# op.c
+#
+use warnings 'misc' ;
+my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
+@a =~ /abc/ ;
+@a =~ s/a/b/ ;
+@a =~ tr/a/b/ ;
+@$b =~ /abc/ ;
+@$b =~ s/a/b/ ;
+@$b =~ tr/a/b/ ;
+%a =~ /abc/ ;
+%a =~ s/a/b/ ;
+%a =~ tr/a/b/ ;
+%$c =~ /abc/ ;
+%$c =~ s/a/b/ ;
+%$c =~ tr/a/b/ ;
+{
+no warnings 'misc' ;
+my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
+@a =~ /abc/ ;
+@a =~ s/a/b/ ;
+@a =~ tr/a/b/ ;
+@$b =~ /abc/ ;
+@$b =~ s/a/b/ ;
+@$b =~ tr/a/b/ ;
+%a =~ /abc/ ;
+%a =~ s/a/b/ ;
+%a =~ tr/a/b/ ;
+%$c =~ /abc/ ;
+%$c =~ s/a/b/ ;
+%$c =~ tr/a/b/ ;
+}
+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.
+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.
+Applying transliteration (tr///) to @array will act on scalar(@array) at - line 10.
+Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 11.
+Applying substitution (s///) to %hash will act on scalar(%hash) at - line 12.
+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
+use warnings 'syntax' ;
+my $a, $b = (1,2);
+no warnings 'syntax' ;
+my $c, $d = (1,2);
+EXPECT
+Parentheses missing around "my" list at - line 3.
+########
+# op.c
+use warnings 'syntax' ;
+local $a, $b = (1,2);
+no warnings 'syntax' ;
+local $c, $d = (1,2);
+EXPECT
+Parentheses missing around "local" list at - line 3.
+########
+# op.c
+use warnings 'bareword' ;
+print (ABC || 1) ;
+no warnings 'bareword' ;
+print (ABC || 1) ;
+EXPECT
+Bareword found in conditional at - line 3.
+########
+--FILE-- abc
+
+--FILE--
+# op.c
+use warnings 'misc' ;
+open FH, "<abc" ;
+$x = 1 if $x = <FH> ;
+no warnings 'misc' ;
+$x = 1 if $x = <FH> ;
+EXPECT
+Value of <HANDLE> construct can be "0"; test with defined() at - line 4.
+########
+# op.c
+use warnings 'misc' ;
+opendir FH, "." ;
+$x = 1 if $x = readdir FH ;
+no warnings 'misc' ;
+$x = 1 if $x = readdir FH ;
+closedir FH ;
+EXPECT
+Value of readdir() operator can be "0"; test with defined() at - line 4.
+########
+# op.c
+use warnings 'misc' ;
+$x = 1 if $x = <*> ;
+no warnings 'misc' ;
+$x = 1 if $x = <*> ;
+EXPECT
+Value of glob construct can be "0"; test with defined() at - line 3.
+########
+# op.c
+use warnings 'misc' ;
+%a = (1,2,3,4) ;
+$x = 1 if $x = each %a ;
+no warnings 'misc' ;
+$x = 1 if $x = each %a ;
+EXPECT
+Value of each() operator can be "0"; test with defined() at - line 4.
+########
+# op.c
+use warnings 'misc' ;
+$x = 1 while $x = <*> and 0 ;
+no warnings 'misc' ;
+$x = 1 while $x = <*> and 0 ;
+EXPECT
+Value of glob construct can be "0"; test with defined() at - line 3.
+########
+# op.c
+use warnings 'misc' ;
+opendir FH, "." ;
+$x = 1 while $x = readdir FH and 0 ;
+no warnings 'misc' ;
+$x = 1 while $x = readdir FH and 0 ;
+closedir FH ;
+EXPECT
+Value of readdir() operator can be "0"; test with defined() at - line 4.
+########
+# op.c
+use warnings 'redefine' ;
+sub fred {}
+sub fred {}
+no warnings 'redefine' ;
+sub fred {}
+EXPECT
+Subroutine fred redefined at - line 4.
+########
+# op.c
+use warnings 'redefine' ;
+sub fred () { 1 }
+sub fred () { 1 }
+no warnings 'redefine' ;
+sub fred () { 1 }
+EXPECT
+Constant subroutine fred redefined at - line 4.
+########
+# op.c
+no warnings 'redefine' ;
+sub fred () { 1 }
+sub fred () { 2 }
+EXPECT
+Constant subroutine fred redefined at - line 4.
+########
+# op.c
+no warnings 'redefine' ;
+sub fred () { 1 }
+*fred = sub () { 2 };
+EXPECT
+Constant subroutine main::fred redefined at - line 4.
+########
+# op.c
+use warnings 'redefine' ;
+format FRED =
+.
+format FRED =
+.
+no warnings 'redefine' ;
+format FRED =
+.
+EXPECT
+Format FRED redefined at - line 5.
+########
+# op.c
+use warnings 'deprecated' ;
+push FRED;
+no warnings 'deprecated' ;
+push FRED;
+EXPECT
+Array @FRED missing the @ in argument 1 of push() at - line 3.
+########
+# op.c
+use warnings 'deprecated' ;
+@a = keys FRED ;
+no warnings 'deprecated' ;
+@a = keys FRED ;
+EXPECT
+Hash %FRED missing the % in argument 1 of keys() at - line 3.
+########
+# op.c
+BEGIN {
+    if ($^O eq 'MacOS') {
+	print <<EOM;
+SKIPPED
+# no exec on Mac OS
+EOM
+	exit;
+    }
+}
+use warnings 'syntax' ;
+exec "$^X -e 1" ; 
+my $a
+EXPECT
+Statement unlikely to be reached at - line 13.
+	(Maybe you meant system() when you said exec()?)
+########
+# op.c
+use warnings 'deprecated' ;
+my @a; defined(@a);
+EXPECT
+defined(@array) is deprecated at - line 3.
+	(Maybe you should just omit the defined()?)
+########
+# op.c
+use warnings 'deprecated' ;
+defined(@a = (1,2,3));
+EXPECT
+defined(@array) is deprecated at - line 3.
+	(Maybe you should just omit the defined()?)
+########
+# op.c
+use warnings 'deprecated' ;
+my %h; defined(%h);
+EXPECT
+defined(%hash) is deprecated at - line 3.
+	(Maybe you should just omit the defined()?)
+########
+# op.c
+BEGIN {
+    if ($^O eq 'MacOS') {
+	print <<EOM;
+SKIPPED
+# no exec on Mac OS
+EOM
+	exit;
+    }
+}
+no warnings 'syntax' ;
+exec "$^X -e 1" ; 
+my $a
+EXPECT
+
+########
+# op.c
+sub fred();
+sub fred($) {}
+EXPECT
+Prototype mismatch: sub main::fred () vs ($) at - line 3.
+########
+# op.c
+$^W = 0 ;
+sub fred() ;
+sub fred($) {}
+{
+    no warnings 'prototype' ;
+    sub Fred() ;
+    sub Fred($) {}
+    use warnings 'prototype' ;
+    sub freD() ;
+    sub freD($) {}
+}
+sub FRED() ;
+sub FRED($) {}
+EXPECT
+Prototype mismatch: sub main::fred () vs ($) at - line 4.
+Prototype mismatch: sub main::freD () vs ($) at - line 11.
+Prototype mismatch: sub main::FRED () vs ($) at - line 14.
+########
+# op.c
+use warnings 'syntax' ;
+join /---/, 'x', 'y', 'z';
+EXPECT
+/---/ should probably be written as "---" at - line 3.
+########
+# op.c [Perl_peep]
+use warnings 'prototype' ;
+fred() ; 
+sub fred ($$) {}
+no warnings 'prototype' ;
+joe() ; 
+sub joe ($$) {}
+EXPECT
+main::fred() called too early to check prototype at - line 3.
+########
+# op.c [Perl_newATTRSUB]
+--FILE-- abc.pm
+use warnings 'void' ;
+BEGIN { $| = 1; print "in begin\n"; }
+CHECK { print "in check\n"; }
+INIT { print "in init\n"; }
+END { print "in end\n"; }
+print "in mainline\n";
+1;
+--FILE--
+use abc;
+delete $INC{"abc.pm"};
+require abc;
+do "abc.pm";
+EXPECT
+in begin
+in mainline
+in check
+in init
+in begin
+Too late to run CHECK block at abc.pm line 3.
+Too late to run INIT block at abc.pm line 4.
+in mainline
+in begin
+Too late to run CHECK block at abc.pm line 3.
+Too late to run INIT block at abc.pm line 4.
+in mainline
+in end
+in end
+in end
+########
+# op.c [Perl_newATTRSUB]
+--FILE-- abc.pm
+no warnings 'void' ;
+BEGIN { $| = 1; print "in begin\n"; }
+CHECK { print "in check\n"; }
+INIT { print "in init\n"; }
+END { print "in end\n"; }
+print "in mainline\n";
+1;
+--FILE--
+require abc;
+do "abc.pm";
+EXPECT
+in begin
+in mainline
+in begin
+in mainline
+in end
+in end
+########
+# op.c
+my @x;
+use warnings 'syntax' ;
+push(@x);
+unshift(@x);
+no warnings 'syntax' ;
+push(@x);
+unshift(@x);
+EXPECT
+Useless use of push with no values at - line 4.
+Useless use of unshift with no values at - line 5.
+########
+# op.c
+use warnings 'deprecated' ;
+package;
+no warnings 'deprecated' ;
+package;
+EXPECT
+Use of "package" with no arguments is deprecated at - line 3.
+Global symbol "BEGIN" requires explicit package name at - line 4.
+BEGIN not safe after errors--compilation aborted at - line 4.
+########
+# op.c
+# 20020401 mjd@plover.com at suggestion of jfriedl@yahoo.com
+use warnings 'regexp';
+split /blah/g, "blah";
+no warnings 'regexp';
+split /blah/g, "blah";
+EXPECT
+Use of /g modifier is meaningless in split at - line 4.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/perl b/gnu/usr.bin/perl/t/lib/warnings/perl
new file mode 100644
index 00000000000..78d730b3619
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/perl
@@ -0,0 +1,73 @@
+  perl.c	AOK
+
+  gv_check(defstash)
+	Name \"%s::%s\" used only once: possible typo 
+
+  Mandatory Warnings All TODO
+  ------------------
+  Recompile perl with -DDEBUGGING to use -D switch	[moreswitches]
+  Unbalanced scopes: %ld more ENTERs than LEAVEs	[perl_destruct]
+  Unbalanced saves: %ld more saves than restores	[perl_destruct]
+  Unbalanced tmps: %ld more allocs than frees		[perl_destruct]
+  Unbalanced context: %ld more PUSHes than POPs		[perl_destruct]
+  Unbalanced string table refcount: (%d) for \"%s\"	[perl_destruct]
+  Scalars leaked: %ld					[perl_destruct]
+
+
+__END__
+# perl.c
+no warnings 'once' ;
+$x = 3 ;
+use warnings 'once' ;
+$z = 3 ;
+EXPECT
+Name "main::z" used only once: possible typo at - line 5.
+########
+-w
+# perl.c
+$x = 3 ;
+no warnings 'once' ;
+$z = 3 
+EXPECT
+Name "main::x" used only once: possible typo at - line 3.
+########
+# perl.c
+BEGIN { $^W =1 ; }
+$x = 3 ;
+no warnings 'once' ;
+$z = 3 
+EXPECT
+Name "main::x" used only once: possible typo at - line 3.
+########
+-W
+# perl.c
+no warnings 'once' ;
+$x = 3 ;
+use warnings 'once' ;
+$z = 3 ;
+EXPECT
+OPTION random
+Name "main::z" used only once: possible typo at - line 6.
+Name "main::x" used only once: possible typo at - line 4.
+########
+-X
+# perl.c
+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/gnu/usr.bin/perl/t/lib/warnings/perlio b/gnu/usr.bin/perl/t/lib/warnings/perlio
new file mode 100644
index 00000000000..63279ee0fe8
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/perlio
@@ -0,0 +1,58 @@
+  perlio.c 
+
+
+  Mandatory Warnings ALL TODO
+  ------------------
+    Setting cnt to %d
+    Setting ptr %p > end+1 %p
+    Setting cnt to %d, ptr implies %d
+
+
+perlio: invalid separator character %c%c%c in layer specification list %s
+
+    open(F, ">:-aa", "bb")
+
+
+perlio: argument list not closed for layer \"%.*s\""
+
+    open(F, ">:aa(", "bb")
+
+perlio: unknown layer \"%.*s\"
+
+    # PerlIO/xyz.pm has 1;
+    open(F, ">xyz", "bb")
+
+__END__
+
+# perlio [PerlIO_parse_layers]
+no warnings 'layer';
+open(F, ">:-aa", "bb");
+use warnings 'layer';
+open(F, ">:-aa", "bb");
+close F;
+EXPECT
+perlio: invalid separator character '-' in layer specification list -aa at - line 6.
+########
+
+# perlio [PerlIO_parse_layers]
+no warnings 'layer';
+open(F, ">:aa(", "bb");
+use warnings 'layer';
+open(F, ">:aa(", "bb");
+close F;
+EXPECT
+perlio: argument list not closed for layer "aa(" at - line 6.
+########
+
+--FILE-- PerlIO/xyz.pm
+1;
+--FILE--
+# perlio [PerlIO_parse_layers]
+no warnings 'layer';
+open(F, ">:xyz", "bb");
+use warnings 'layer';
+open(F, ">:xyz", "bb");
+close F;
+END { 1 while unlink "bb" } # KEEP THIS WITH THE LAST TEST.
+EXPECT
+perlio: unknown layer "xyz".
diff --git a/gnu/usr.bin/perl/t/lib/warnings/perly b/gnu/usr.bin/perl/t/lib/warnings/perly
new file mode 100644
index 00000000000..afc5dccc72f
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/perly
@@ -0,0 +1,31 @@
+  perly.y	AOK
+
+  dep() => deprecate("\"do\" to call subroutines") 
+  Use of "do" to call subroutines is deprecated
+
+	sub fred {} do fred()
+	sub fred {} do fred(1)
+	sub fred {} $a = "fred" ; do $a()
+	sub fred {} $a = "fred" ; do $a(1)
+
+
+__END__
+# perly.y
+use warnings 'deprecated' ;
+sub fred {} 
+do fred() ;
+do fred(1) ;
+$a = "fred" ; 
+do $a() ;
+do $a(1) ;
+no warnings 'deprecated' ;
+do fred() ;
+do fred(1) ;
+$a = "fred" ; 
+do $a() ;
+do $a(1) ;
+EXPECT
+Use of "do" to call subroutines is deprecated at - line 4.
+Use of "do" to call subroutines is deprecated at - line 5.
+Use of "do" to call subroutines is deprecated at - line 7.
+Use of "do" to call subroutines is deprecated at - line 8.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/pp b/gnu/usr.bin/perl/t/lib/warnings/pp
new file mode 100644
index 00000000000..5ed7aa08916
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/pp
@@ -0,0 +1,104 @@
+  pp.c	TODO
+
+  substr outside of string
+    $a = "ab" ; $b = substr($a, 4,5) ;
+
+  Attempt to use reference as lvalue in substr 
+    $a = "ab" ; $b = \$a ;  substr($b, 1,1) = $b
+
+  Use of uninitialized value in ref-to-glob cast	[pp_rv2gv()]
+	*b = *{ undef()}
+
+  Use of uninitialized value in scalar dereference	[pp_rv2sv()]
+	my $a = undef ; my $b = $$a
+
+  Odd number of elements in hash list
+	my $a = { 1,2,3 } ;
+
+  Explicit blessing to '' (assuming package main)
+	bless \[], "";
+
+  Constant subroutine %s undefined
+	sub foo () { 1 }; undef &foo;
+
+  Constant subroutine (anonymous) undefined
+	$foo = sub () { 3 }; undef &$foo;
+
+__END__
+# pp.c
+use warnings 'substr' ;
+$a = "ab" ; 
+$b = substr($a, 4,5) ;
+no warnings 'substr' ;
+$a = "ab" ; 
+$b = substr($a, 4,5)  ;
+EXPECT
+substr outside of string at - line 4.
+########
+# pp.c
+use warnings 'substr' ;
+$a = "ab" ; 
+$b = \$a ;  
+substr($b, 1,1) = "ab" ;
+no warnings 'substr' ;
+substr($b, 1,1) = "ab" ;
+EXPECT
+Attempt to use reference as lvalue in substr at - line 5.
+########
+# pp.c
+use warnings 'uninitialized' ;
+*x = *{ undef() };
+no warnings 'uninitialized' ;
+*y = *{ undef() };
+EXPECT
+Use of uninitialized value in ref-to-glob cast at - line 3.
+########
+# pp.c
+use warnings 'uninitialized';
+$x = undef; $y = $$x;
+no warnings 'uninitialized' ;
+$u = undef; $v = $$u;
+EXPECT
+Use of uninitialized value in scalar dereference at - line 3.
+########
+# pp.c
+use warnings 'misc' ;
+my $a = { 1,2,3};
+no warnings 'misc' ;
+my $b = { 1,2,3};
+EXPECT
+Odd number of elements in anonymous hash at - line 3.
+########
+# pp.c
+use warnings 'misc' ;
+bless \[], "" ;
+no warnings 'misc' ;
+bless \[], "" ;
+EXPECT
+Explicit blessing to '' (assuming package main) at - line 3.
+########
+# pp.c
+use warnings 'misc';
+sub foo () { 1 }
+undef &foo;
+no warnings 'misc';
+sub bar () { 2 }
+undef &bar;
+EXPECT
+Constant subroutine foo undefined at - line 4.
+########
+# pp.c
+use warnings 'misc';
+$foo = sub () { 3 };
+undef &$foo;
+no warnings 'misc';
+$bar = sub () { 4 };
+undef &$bar;
+EXPECT
+Constant subroutine (anonymous) undefined at - line 4.
+########
+# pp.c
+use utf8 ;
+$_ = "\x80  \xff" ;
+reverse ;
+EXPECT
diff --git a/gnu/usr.bin/perl/t/lib/warnings/pp_ctl b/gnu/usr.bin/perl/t/lib/warnings/pp_ctl
new file mode 100644
index 00000000000..59ced2b4460
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/pp_ctl
@@ -0,0 +1,242 @@
+  pp_ctl.c	AOK
+ 
+     Not enough format arguments	
+ 	format STDOUT =
+ 	@<<< @<<<
+ 	$a
+ 	.
+ 	write;
+     
+
+    Exiting substitution via %s
+	$_ = "abc" ;
+	while ($i ++ == 0)
+	{
+    	    s/ab/last/e ;
+	}
+
+    Exiting subroutine via %s		
+	sub fred { last }
+	{ fred() }
+
+    Exiting eval via %s	
+	{ eval "last" }
+
+    Exiting pseudo-block via %s 
+	@a = (1,2) ; @b = sort { last } @a ;
+
+    Exiting substitution via %s
+	$_ = "abc" ;
+	last fred:
+	while ($i ++ == 0)
+	{
+    	    s/ab/last fred/e ;
+	}
+
+
+    Exiting subroutine via %s
+	sub fred { last joe }
+	joe: { fred() }
+
+    Exiting eval via %s
+	fred: { eval "last fred" }
+
+    Exiting pseudo-block via %s 
+	@a = (1,2) ; fred: @b = sort { last fred } @a ;
+
+
+    Deep recursion on subroutine \"%s\"
+	sub fred
+	{
+    	  fred() if $a++ < 200
+	}
+	 
+	fred()
+
+      (in cleanup) foo bar
+	package Foo;
+	DESTROY { die "foo bar" }
+	{ bless [], 'Foo' for 1..10 }
+
+__END__
+# pp_ctl.c
+use warnings 'syntax' ;
+format STDOUT =
+@<<< @<<<
+1
+.
+write;
+EXPECT
+Not enough format arguments at - line 5.
+1
+########
+# pp_ctl.c
+no warnings 'syntax' ;
+format =
+@<<< @<<<
+1
+.
+write ;
+EXPECT
+1
+########
+# pp_ctl.c
+use warnings 'exiting' ;
+$_ = "abc" ;
+ 
+while ($i ++ == 0)
+{
+    s/ab/last/e ;
+}
+no warnings 'exiting' ;
+while ($i ++ == 0)
+{
+    s/ab/last/e ;
+}
+EXPECT
+Exiting substitution via last at - line 7.
+########
+# pp_ctl.c
+use warnings 'exiting' ;
+sub fred { last }
+{ fred() }
+no warnings 'exiting' ;
+sub joe { last }
+{ joe() }
+EXPECT
+Exiting subroutine via last at - line 3.
+########
+# pp_ctl.c
+{
+  eval "use warnings 'exiting' ; last;" 
+}
+print STDERR $@ ;
+{
+  eval "no warnings 'exiting' ;last;" 
+} 
+print STDERR $@ ;
+EXPECT
+Exiting eval via last at (eval 1) line 1.
+########
+# pp_ctl.c
+use warnings 'exiting' ;
+@a = (1,2) ;
+@b = sort { last } @a ;
+no warnings 'exiting' ;
+@b = sort { last } @a ;
+EXPECT
+Exiting pseudo-block via last at - line 4.
+Can't "last" outside a loop block at - line 4.
+########
+# pp_ctl.c
+use warnings 'exiting' ;
+$_ = "abc" ;
+fred: 
+while ($i ++ == 0)
+{
+    s/ab/last fred/e ;
+}
+no warnings 'exiting' ;
+while ($i ++ == 0)
+{
+    s/ab/last fred/e ;
+}
+EXPECT
+Exiting substitution via last at - line 7.
+########
+# pp_ctl.c
+use warnings 'exiting' ;
+sub fred { last joe }
+joe: { fred() }
+no warnings 'exiting' ;
+sub Fred { last Joe }
+Joe: { Fred() }
+EXPECT
+Exiting subroutine via last at - line 3.
+########
+# pp_ctl.c
+joe:
+{ eval "use warnings 'exiting' ; last joe;" }
+print STDERR $@ ;
+Joe:
+{ eval "no warnings 'exiting' ; last Joe;" }
+print STDERR $@ ;
+EXPECT
+Exiting eval via last at (eval 1) line 1.
+########
+# pp_ctl.c
+use warnings 'exiting' ;
+@a = (1,2) ;
+fred: @b = sort { last fred } @a ;
+no warnings 'exiting' ;
+Fred: @b = sort { last Fred } @a ;
+EXPECT
+Exiting pseudo-block via last at - line 4.
+Label not found for "last fred" at - line 4.
+########
+# pp_ctl.c
+use warnings 'recursion' ;
+BEGIN { warn "PREFIX\n" ;}
+sub fred
+{
+    fred() if $a++ < 200
+}
+ 
+fred()
+EXPECT
+Deep recursion on subroutine "main::fred" at - line 6.
+########
+# pp_ctl.c
+no warnings 'recursion' ;
+BEGIN { warn "PREFIX\n" ;}
+sub fred
+{
+    fred() if $a++ < 200
+}
+ 
+fred()
+EXPECT
+########
+# pp_ctl.c
+use warnings 'misc' ;
+package Foo;
+DESTROY { die "@{$_[0]} foo bar" }
+{ bless ['A'], 'Foo' for 1..10 }
+{ bless ['B'], 'Foo' for 1..10 }
+EXPECT
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+########
+# pp_ctl.c
+no warnings 'misc' ;
+package Foo;
+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 'portable';
+eval 'use 5.6.1';
+EXPECT
+v-string in use/require non-portable at (eval 1) line 2.
+########
+# pp_ctl.c
+use warnings 'portable';
+eval 'use v5.6.1';
+EXPECT
+v-string in use/require non-portable at (eval 1) line 2.
+########
+# pp_ctl.c
+use warnings;
+{
+    no warnings;
+    eval 'print $foo';
+}
+EXPECT
diff --git a/gnu/usr.bin/perl/t/lib/warnings/pp_hot b/gnu/usr.bin/perl/t/lib/warnings/pp_hot
new file mode 100644
index 00000000000..c008dd5f106
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/pp_hot
@@ -0,0 +1,328 @@
+  pp_hot.c	
+
+  print() on unopened filehandle abc		[pp_print]
+    $f = $a = "abc" ; print $f $a
+
+  Filehandle %s opened only for input		[pp_print]
+    print STDIN "abc" ;
+
+  Filehandle %s opened only for output		[pp_print]
+    $a = <STDOUT> ;
+
+  print() on closed filehandle %s		[pp_print]
+    close STDIN ; print STDIN "abc" ;
+
+  uninitialized					[pp_rv2av]
+	my $a = undef ; my @b = @$a
+
+  uninitialized					[pp_rv2hv]
+	my $a = undef ; my %b = %$a
+
+  Odd number of elements in hash list		[pp_aassign]
+	%X = (1,2,3) ;
+
+  Reference found where even-sized list expected [pp_aassign]
+	$X = [ 1 ..3 ];
+
+  Filehandle %s opened only for output		[Perl_do_readline] 
+  	open (FH, ">./xcv") ;
+	my $a = <FH> ;
+
+  glob failed (can't start child: %s)		[Perl_do_readline] <<TODO
+
+  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]
+    sub fred { fred() if $a++ < 200} fred()
+
+  Deep recursion on anonymous subroutine 	[Perl_sub_crush_depth]
+    $a = sub { &$a if $a++ < 200} &$a
+
+  Possible Y2K bug: about to append an integer to '19' [pp_concat]
+    $x     = "19$yy\n";
+
+  Use of reference "%s" as array index [pp_aelem]
+    $x[\1]
+
+__END__
+# pp_hot.c [pp_print]
+use warnings 'unopened' ;
+$f = $a = "abc" ; 
+print $f $a;
+no warnings 'unopened' ;
+print $f $a;
+EXPECT
+print() on unopened filehandle abc at - line 4.
+########
+# pp_hot.c [pp_print]
+use warnings 'io' ;
+# There is no guarantee that STDOUT is output only, or STDIN input only.
+# Certainly on some BSDs (at least FreeBSD, Darwin, BSDi) file descriptors
+# 1 and 2 are opened read/write on the tty, and the IO layers may reflect this.
+# So we must make our own file handle that is read only.
+my $file = "./xcv" ; unlink $file ;
+open (FH, ">$file") or die $! ;
+close FH or die $! ;
+die "There is no file $file" unless -f $file ;
+open (FH, "<$file") or die $! ;
+print FH "anc" ;
+open(FOO, "<&FH") or die $! ;
+print FOO "anc" ;
+no warnings 'io' ;
+print FH "anc" ;
+print FOO "anc" ;
+use warnings 'io' ;
+print FH "anc" ;
+print FOO "anc" ;
+close (FH) or die $! ;
+close (FOO) or die $! ;
+unlink $file ;
+EXPECT
+Filehandle FH opened only for input at - line 12.
+Filehandle FOO opened only for input at - line 14.
+Filehandle FH opened only for input at - line 19.
+Filehandle FOO opened only for input at - line 20.
+########
+# pp_hot.c [pp_print]
+use warnings 'closed' ;
+close STDIN ;
+print STDIN "anc";
+opendir STDIN, ".";
+print STDIN "anc";
+closedir STDIN;
+no warnings 'closed' ;
+print STDIN "anc";
+opendir STDIN, ".";
+print STDIN "anc";
+EXPECT
+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_print]
+# [ID 20020425.012] from Dave Steiner <steiner@bakerst.rutgers.edu>
+# This goes segv on 5.7.3
+use warnings 'closed' ;
+my $fh = *STDOUT{IO};
+close STDOUT or die "Can't close STDOUT";
+print $fh "Shouldn't print anything, but shouldn't SEGV either\n";
+EXPECT
+print() on closed filehandle at - line 7.
+########
+# pp_hot.c [pp_print]
+package foo;
+use warnings 'closed';
+open my $fh1, "nonexistent";
+print $fh1 42;
+open $fh2, "nonexistent";
+print $fh2 42;
+open $bar::fh3, "nonexistent";
+print $bar::fh3 42;
+open bar::FH4, "nonexistent";
+print bar::FH4 42;
+EXPECT
+print() on closed filehandle $fh1 at - line 5.
+print() on closed filehandle $fh2 at - line 7.
+print() on closed filehandle $fh3 at - line 9.
+print() on closed filehandle FH4 at - line 11.
+########
+# pp_hot.c [pp_rv2av]
+use warnings 'uninitialized' ;
+my $a = undef ;
+my @b = @$a;
+no warnings 'uninitialized' ;
+my @c = @$a;
+EXPECT
+Use of uninitialized value in array dereference at - line 4.
+########
+# pp_hot.c [pp_rv2hv]
+use warnings 'uninitialized' ;
+my $a = undef ;
+my %b = %$a;
+no warnings 'uninitialized' ;
+my %c = %$a;
+EXPECT
+Use of uninitialized value in hash dereference at - line 4.
+########
+# pp_hot.c [pp_aassign]
+use warnings 'misc' ;
+my %X ; %X = (1,2,3) ;
+no warnings 'misc' ;
+my %Y ; %Y = (1,2,3) ;
+EXPECT
+Odd number of elements in hash assignment at - line 3.
+########
+# pp_hot.c [pp_aassign]
+use warnings 'misc' ;
+my %X ; %X = [1 .. 3] ;
+no warnings 'misc' ;
+my %Y ; %Y = [1 .. 3] ;
+EXPECT
+Reference found where even-sized list expected at - line 3.
+########
+# pp_hot.c [Perl_do_readline]
+use warnings 'closed' ;
+close STDIN        ; $a = <STDIN> ;
+opendir STDIN, "." ; $a = <STDIN> ;
+closedir STDIN;
+no warnings 'closed' ;
+opendir STDIN, "." ; $a = <STDIN> ;
+$a = <STDIN> ;
+EXPECT
+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' ;
+my $file = "./xcv" ; unlink $file ;
+open (FH, ">$file") or die $! ;
+my $a = <FH> ;
+no warnings 'io' ;
+$a = <FH> ;
+use warnings 'io' ;
+open(FOO, ">&FH") or die $! ;
+$a = <FOO> ;
+no warnings 'io' ;
+$a = <FOO> ;
+use warnings 'io' ;
+$a = <FOO> ;
+$a = <FH> ;
+close (FH) or die $! ;
+close (FOO) or die $! ;
+unlink $file ;
+EXPECT
+Filehandle FH opened only for output at - line 5.
+Filehandle FOO opened only for output at - line 10.
+Filehandle FOO opened only for output at - line 14.
+Filehandle FH opened only for output at - line 15.
+########
+# pp_hot.c [Perl_sub_crush_depth]
+use warnings 'recursion' ;
+sub fred 
+{ 
+    fred() if $a++ < 200
+} 
+{
+  local $SIG{__WARN__} = sub {
+    die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/
+  };
+  fred();
+}
+EXPECT
+ok
+########
+# pp_hot.c [Perl_sub_crush_depth]
+no warnings 'recursion' ;
+sub fred 
+{ 
+    fred() if $a++ < 200
+} 
+{
+  local $SIG{__WARN__} = sub {
+    die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/
+  };
+  fred();
+}
+EXPECT
+
+########
+# pp_hot.c [Perl_sub_crush_depth]
+use warnings 'recursion' ;
+$b = sub 
+{ 
+    &$b if $a++ < 200
+}  ;
+
+&$b ;
+EXPECT
+Deep recursion on anonymous subroutine at - line 5.
+########
+# pp_hot.c [Perl_sub_crush_depth]
+no warnings 'recursion' ;
+$b = sub 
+{ 
+    &$b if $a++ < 200
+}  ;
+
+&$b ;
+EXPECT
+########
+# pp_hot.c [pp_concat]
+use warnings 'uninitialized';
+my($x, $y);
+sub a { shift }
+a($x . "x");	# should warn once
+a($x . $y);	# should warn twice
+$x .= $y;	# should warn once
+$y .= $y;	# should warn once
+EXPECT
+Use of uninitialized value in concatenation (.) or string at - line 5.
+Use of uninitialized value in concatenation (.) or string at - line 6.
+Use of uninitialized value in concatenation (.) or string at - line 6.
+Use of uninitialized value in concatenation (.) or string at - line 7.
+Use of uninitialized value in concatenation (.) or string at - line 8.
+########
+# pp_hot.c [pp_concat]
+use warnings 'y2k';
+use Config;
+BEGIN {
+    unless ($Config{ccflags} =~ /Y2KWARN/) {
+	print "SKIPPED\n# perl not built with -DPERL_Y2KWARN";
+	exit 0;
+    }
+}
+my $x;
+my $yy = 78;
+$x     = "19$yy\n";
+$x     = "19" . $yy . "\n";
+$x     = "319$yy\n";
+$x     = "319" . $yy . "\n";
+$yy = 19;
+$x     = "ok $yy\n";
+$yy = 9;
+$x     = 1 . $yy;
+no warnings 'y2k';
+$x     = "19$yy\n";
+$x     = "19" . $yy . "\n";
+EXPECT
+Possible Y2K bug: about to append an integer to '19' at - line 12.
+Possible Y2K bug: about to append an integer to '19' at - line 13.
+########
+# pp_hot.c [pp_aelem]
+{
+use warnings 'misc';
+print $x[\1];
+}
+{
+no warnings 'misc';
+print $x[\1];
+}
+
+EXPECT
+OPTION regex
+Use of reference ".*" as array index at - line 4.
+########
+# pp_hot.c [pp_aelem]
+package Foo;use overload q("") => sub {};package main;$a = bless {}, "Foo";
+$b = {};
+{
+use warnings 'misc';
+print $x[$a];
+print $x[$b];
+}
+{
+no warnings 'misc';
+print $x[$a];
+print $x[$b];
+}
+
+EXPECT
+OPTION regex
+Use of reference ".*" as array index at - line 7.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/pp_pack b/gnu/usr.bin/perl/t/lib/warnings/pp_pack
new file mode 100644
index 00000000000..62fa6ecfc73
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/pp_pack
@@ -0,0 +1,95 @@
+  pp.c	TODO
+
+  Invalid type in unpack: '%c
+	my $A = pack ("A,A", 1,2) ;
+	my @A = unpack ("A,A", "22") ;
+
+  Attempt to pack pointer to temporary value
+	pack("p", "abc") ;
+
+__END__
+# pp_pack.c
+use warnings 'pack' ;
+use warnings 'unpack' ;
+my @a = unpack ("A,A", "22") ;
+my $a = pack ("A,A", 1,2) ;
+no warnings 'pack' ;
+no warnings 'unpack' ;
+my @b = unpack ("A,A", "22") ;
+my $b = pack ("A,A", 1,2) ;
+EXPECT
+Invalid type in unpack: ',' at - line 4.
+Invalid type in pack: ',' at - line 5.
+########
+# pp.c
+use warnings 'uninitialized' ;
+my $a = undef ; 
+my $b = $$a;
+no warnings 'uninitialized' ;
+my $c = $$a;
+EXPECT
+Use of uninitialized value in scalar dereference at - line 4.
+########
+# pp_pack.c
+use warnings 'pack' ;
+sub foo { my $a = "a"; return $a . $a++ . $a++ }
+my $a = pack("p", &foo) ;
+no warnings 'pack' ;
+my $b = pack("p", &foo) ;
+EXPECT
+Attempt to pack pointer to temporary value at - line 4.
+########
+# pp.c
+use warnings 'misc' ;
+bless \[], "" ;
+no warnings 'misc' ;
+bless \[], "" ;
+EXPECT
+Explicit blessing to '' (assuming package main) at - line 3.
+########
+# pp.c
+use utf8 ;
+$_ = "\x80  \xff" ;
+reverse ;
+EXPECT
+########
+# pp_pack.c
+use warnings 'pack' ;
+print unpack("C", pack("C",   -1)), "\n",
+	unpack("C", pack("C",    0)), "\n",
+	unpack("C", pack("C",  255)), "\n",
+	unpack("C", pack("C",  256)), "\n",
+	unpack("c", pack("c", -129)), "\n",
+	unpack("c", pack("c", -128)), "\n",
+	unpack("c", pack("c",  127)), "\n",
+	unpack("c", pack("c",  128)), "\n";
+no warnings 'pack' ;
+print unpack("C", pack("C",   -1)), "\n";
+print unpack("C", pack("C",    0)), "\n";
+print unpack("C", pack("C",  255)), "\n";
+print unpack("C", pack("C",  256)), "\n";
+print unpack("c", pack("c", -129)), "\n";
+print unpack("c", pack("c", -128)), "\n";
+print unpack("c", pack("c",  127)), "\n";
+print unpack("c", pack("c",  128)), "\n";
+EXPECT
+Character in "C" format wrapped at - line 3.
+Character in "C" format wrapped at - line 3.
+Character in "c" format wrapped at - line 3.
+Character in "c" format wrapped at - line 3.
+255
+0
+255
+0
+127
+-128
+127
+-128
+255
+0
+255
+0
+127
+-128
+127
+-128
diff --git a/gnu/usr.bin/perl/t/lib/warnings/pp_sys b/gnu/usr.bin/perl/t/lib/warnings/pp_sys
new file mode 100644
index 00000000000..be8bb6244c2
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/pp_sys
@@ -0,0 +1,439 @@
+  pp_sys.c 	AOK
+
+  untie attempted while %d inner references still exist	[pp_untie]
+    sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ;
+
+  fileno() on unopened filehandle abc		[pp_fileno]
+    $a = "abc"; fileno($a)
+
+  binmode() on unopened filehandle abc		[pp_binmode]
+    $a = "abc"; fileno($a)
+
+  printf() on unopened filehandle abc		[pp_prtf]
+    $a = "abc"; printf $a "fred"
+
+  Filehandle %s opened only for input		[pp_leavewrite]
+    format STDIN =
+    .
+    write STDIN;
+
+  write() on closed filehandle %s		[pp_leavewrite]
+    format STDIN =
+    .
+    close STDIN;
+    write STDIN ;
+
+  page overflow	 				[pp_leavewrite]
+
+  printf() on unopened filehandle abc		[pp_prtf]
+    $a = "abc"; printf $a "fred"
+
+  Filehandle %s opened only for input		[pp_prtf]
+    $a = "abc"; 
+    printf $a "fred"
+
+  printf() on closed filehandle %s		[pp_prtf]
+    close STDIN ;
+    printf STDIN "fred"
+
+  syswrite() on closed filehandle %s		[pp_send]
+    close STDIN; 
+    syswrite STDIN, "fred", 1;
+
+  send() on closed socket %s			[pp_send]
+    close STDIN; 
+    send STDIN, "fred", 1
+
+  bind() on closed socket %s			[pp_bind]
+    close STDIN; 
+    bind STDIN, "fred" ;
+
+
+  connect() on closed socket %s			[pp_connect]
+    close STDIN; 
+    connect STDIN, "fred" ;
+
+  listen() on closed socket %s			[pp_listen]
+    close STDIN; 
+    listen STDIN, 2;
+
+  accept() on closed socket %s			[pp_accept]
+    close STDIN; 
+    accept "fred", STDIN ;
+
+  shutdown() on closed socket %s		[pp_shutdown]
+    close STDIN; 
+    shutdown STDIN, 0;
+
+  setsockopt() on closed socket %s		[pp_ssockopt]
+  getsockopt() on closed socket	%s		[pp_ssockopt]
+    close STDIN; 
+    setsockopt STDIN, 1,2,3;
+    getsockopt STDIN, 1,2;
+
+  getsockname() on closed socket %s		[pp_getpeername]
+  getpeername() on closed socket %s		[pp_getpeername]
+    close STDIN; 
+    getsockname STDIN;
+    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]
+
+  -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" ;
+
+  Filehandle %s opened only for output		[pp_sysread]
+	my $file = "./xcv" ;
+	open(F, ">$file") ; 
+	my $a = sysread(F, $a,10) ;
+
+  lstat on filehandle %s			[pp_lstat]
+
+  getc() on unopened filehandle			[pp_getc]
+
+  getc() on closed filehandle			[pp_getc]
+
+__END__
+# pp_sys.c [pp_untie]
+use warnings 'untie' ;
+sub TIESCALAR { bless [] } ; 
+$b = tie $a, 'main'; 
+untie $a ;
+no warnings 'untie' ;
+$c = tie $d, 'main'; 
+untie $d ;
+EXPECT
+untie attempted while 1 inner references still exist at - line 5.
+########
+# pp_sys.c [pp_leavewrite]
+use warnings 'io' ;
+format STDIN =
+.
+write STDIN;
+no warnings 'io' ;
+write STDIN;
+EXPECT
+Filehandle STDIN opened only for input at - line 5.
+########
+# pp_sys.c [pp_leavewrite]
+use warnings 'closed' ;
+format STDIN =
+.
+close STDIN;
+write STDIN;
+opendir STDIN, ".";
+write STDIN;
+closedir STDIN;
+no warnings 'closed' ;
+write STDIN;
+opendir STDIN, ".";
+write STDIN;
+EXPECT
+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' ;
+format STDOUT_TOP =
+abc
+.
+format STDOUT =
+def
+ghi
+.
+$= = 1 ;
+$- =1 ;
+open STDOUT, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ;
+write ;
+no warnings 'io' ;
+write ;
+EXPECT
+page overflow at - line 13.
+########
+# pp_sys.c [pp_prtf]
+use warnings 'unopened' ;
+$a = "abc"; 
+printf $a "fred";
+no warnings 'unopened' ;
+printf $a "fred";
+EXPECT
+printf() on unopened filehandle abc at - line 4.
+########
+# pp_sys.c [pp_prtf]
+use warnings 'closed' ;
+close STDIN ;
+printf STDIN "fred";
+opendir STDIN, ".";
+printf STDIN "fred";
+closedir STDIN;
+no warnings 'closed' ;
+printf STDIN "fred";
+opendir STDIN, ".";
+printf STDIN "fred";
+EXPECT
+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' ;
+printf STDIN "fred";
+no warnings 'io' ;
+printf STDIN "fred";
+EXPECT
+Filehandle STDIN opened only for input at - line 3.
+########
+# pp_sys.c [pp_send]
+use warnings 'closed' ;
+close STDIN; 
+syswrite STDIN, "fred", 1;
+opendir STDIN, ".";
+syswrite STDIN, "fred", 1;
+closedir STDIN;
+no warnings 'closed' ;
+syswrite STDIN, "fred", 1;
+opendir STDIN, ".";
+syswrite STDIN, "fred", 1;
+EXPECT
+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 ( !$Config{d_flock} &&
+       !$Config{d_fcntl_can_lock} &&
+       !$Config{d_lockf} ) {
+    print <<EOM ;
+SKIPPED
+# flock not present
+EOM
+    exit ;
+  } 
+}
+use warnings qw(unopened closed);
+close STDIN;
+flock STDIN, 8;
+opendir STDIN, ".";
+flock STDIN, 8;
+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 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' ;
+use Config; 
+BEGIN { 
+  if ( $^O ne 'VMS' and ! $Config{d_socket}) {
+    print <<EOM ;
+SKIPPED
+# send not present
+# bind not present
+# connect not present
+# accept not present
+# shutdown not present
+# setsockopt not present
+# getsockopt not present
+# getsockname not present
+# getpeername not present
+EOM
+    exit ;
+  } 
+}
+close STDIN; 
+send STDIN, "fred", 1;
+bind STDIN, "fred" ;
+connect STDIN, "fred" ;
+listen STDIN, 2;
+accept "fred", STDIN;
+shutdown STDIN, 0;
+setsockopt STDIN, 1,2,3;
+getsockopt STDIN, 1,2;
+getsockname STDIN;
+getpeername STDIN;
+opendir STDIN, ".";
+send STDIN, "fred", 1;
+bind STDIN, "fred" ;
+connect STDIN, "fred" ;
+listen STDIN, 2;
+accept "fred", STDIN;
+shutdown STDIN, 0;
+setsockopt STDIN, 1,2,3;
+getsockopt STDIN, 1,2;
+getsockname STDIN;
+getpeername STDIN;
+closedir STDIN;
+no warnings 'io' ;
+send STDIN, "fred", 1;
+bind STDIN, "fred" ;
+connect STDIN, "fred" ;
+listen STDIN, 2;
+accept STDIN, "fred" ;
+shutdown STDIN, 0;
+setsockopt STDIN, 1,2,3;
+getsockopt STDIN, 1,2;
+getsockname STDIN;
+getpeername STDIN;
+opendir STDIN, ".";
+send STDIN, "fred", 1;
+bind STDIN, "fred" ;
+connect STDIN, "fred" ;
+listen STDIN, 2;
+accept "fred", STDIN;
+shutdown STDIN, 0;
+setsockopt STDIN, 1,2,3;
+getsockopt STDIN, 1,2;
+getsockname STDIN;
+getpeername STDIN;
+EXPECT
+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' ;
+stat "abc\ndef";
+no warnings 'newline' ;
+stat "abc\ndef";
+EXPECT
+Unsuccessful stat on filename containing newline at - line 3.
+########
+# pp_sys.c [pp_fttext]
+use warnings qw(unopened closed) ;
+close STDIN ; 
+-T STDIN ;
+stat(STDIN) ;
+-T HOCUS;
+stat(POCUS);
+no warnings qw(unopened closed) ;
+-T STDIN ;
+stat(STDIN);
+-T HOCUS;
+stat(POCUS);
+EXPECT
+-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' ;
+-T "abc\ndef" ;
+no warnings 'newline' ;
+-T "abc\ndef" ;
+EXPECT
+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) ;
+no warnings 'io' ;
+my $a = sysread(F, $a,10) ;
+close F ;
+unlink $file ;
+EXPECT
+Filehandle F opened only for output at - line 12.
+########
+# pp_sys.c [pp_binmode]
+use warnings 'unopened' ;
+binmode(BLARG);
+$a = "BLERG";binmode($a);
+EXPECT
+binmode() on unopened filehandle BLARG at - line 3.
+binmode() on unopened filehandle at - line 4.
+########
+# pp_sys.c [pp_lstat]
+use warnings 'io';
+open FH, "harness" or die "# $!";
+lstat FH;
+open my $fh, $0 or die "# $!";
+lstat $fh;
+no warnings 'io';
+lstat FH;
+lstat $fh;
+close FH;
+close $fh;
+EXPECT
+lstat() on filehandle FH at - line 4.
+lstat() on filehandle $fh at - line 6.
+########
+# pp_sys.c [pp_getc]
+use warnings qw(unopened closed) ;
+getc FOO;
+close STDIN;
+getc STDIN;
+# Create an empty file
+$file = 'getcwarn.tmp';
+open FH1, ">$file" or die "# $!"; close FH1;
+open FH2, $file    or die "# $!";
+getc FH2; # Should not warn at EOF
+close FH2;
+getc FH2; # Warns, now
+unlink $file;
+no warnings qw(unopened closed) ;
+getc FOO;
+getc STDIN;
+getc FH2;
+EXPECT
+getc() on unopened filehandle FOO at - line 3.
+getc() on closed filehandle STDIN at - line 5.
+getc() on closed filehandle FH2 at - line 12.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/regcomp b/gnu/usr.bin/perl/t/lib/warnings/regcomp
new file mode 100644
index 00000000000..e9a8d70a5d9
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/regcomp
@@ -0,0 +1,218 @@
+  regcomp.c	AOK
+
+  Quantifier unexpected on zero-length expression [S_study_chunk] 
+
+  (?p{}) is deprecated - use (??{})  [S_reg]
+    $a =~ /(?p{'x'})/ ;
+    
+
+  Useless (%s%c) - %suse /%c modifier [S_reg] 
+  Useless (%sc) - %suse /gc modifier [S_reg] 
+
+
+
+  Strange *+?{} on zero-length expression	[S_study_chunk]
+	/(?=a)?/
+
+  %.*s matches null string many times   	[S_regpiece]
+	$a = "ABC123" ; $a =~ /(?=a)*/'
+
+  /%.127s/: Unrecognized escape \\%c passed through	[S_regatom] 
+  	$x = '\m' ; /$x/
+
+  POSIX syntax [%c %c] belongs inside character classes	[S_checkposixcc] 
+
+
+  Character class [:%.*s:] unknown	[S_regpposixcc]
+
+  Character class syntax [%c %c] belongs inside character classes [S_checkposixcc] 
+  
+  /%.127s/: false [] range \"%*.*s\" in regexp [S_regclass]
+
+  /%.127s/: false [] range \"%*.*s\" in regexp [S_regclassutf8]
+
+  /%.127s/: Unrecognized escape \\%c in character class passed through"	[S_regclass] 
+
+  /%.127s/: Unrecognized escape \\%c in character class passed through"	[S_regclassutf8] 
+
+  False [] range \"%*.*s\" [S_regclass]
+
+__END__
+# regcomp.c [S_regpiece]
+use warnings 'regexp' ;
+my $a = "ABC123" ; 
+$a =~ /(?=a)*/ ;
+no warnings 'regexp' ;
+$a =~ /(?=a)*/ ;
+EXPECT
+(?=a)* matches null string many times in regex; marked by <-- HERE in m/(?=a)* <-- HERE / at - line 4.
+########
+# regcomp.c [S_regatom]
+$x = '\m' ;
+use warnings 'regexp' ;
+$a =~ /a$x/ ;
+no warnings 'regexp' ;
+$a =~ /a$x/ ;
+EXPECT
+Unrecognized escape \m passed through in regex; marked by <-- HERE in m/a\m <-- HERE / at - line 4.
+########
+# regcomp.c [S_regpposixcc S_checkposixcc]
+#
+use warnings 'regexp' ;
+$_ = "" ;
+/[:alpha:]/;
+/[:zog:]/;
+no warnings 'regexp' ;
+/[:alpha:]/;
+/[:zog:]/;
+EXPECT
+POSIX syntax [: :] belongs inside character classes in regex; marked by <-- HERE in m/[:alpha:] <-- HERE / at - line 5.
+POSIX syntax [: :] belongs inside character classes in regex; marked by <-- HERE in m/[:zog:] <-- HERE / at - line 6.
+########
+# regcomp.c [S_checkposixcc]
+#
+use warnings 'regexp' ;
+$_ = "" ;
+/[.zog.]/;
+no warnings 'regexp' ;
+/[.zog.]/;
+EXPECT
+POSIX syntax [. .] belongs inside character classes in regex; marked by <-- HERE in m/[.zog.] <-- HERE / at - line 5.
+POSIX syntax [. .] is reserved for future extensions in regex; marked by <-- HERE in m/[.zog.] <-- HERE /
+########
+# regcomp.c [S_regclass]
+$_ = "";
+use warnings 'regexp' ;
+/[a-b]/;
+/[a-\d]/;
+/[\d-b]/;
+/[\s-\d]/;
+/[\d-\s]/;
+/[a-[:digit:]]/;
+/[[:digit:]-b]/;
+/[[:alpha:]-[:digit:]]/;
+/[[:digit:]-[:alpha:]]/;
+no warnings 'regexp' ;
+/[a-b]/;
+/[a-\d]/;
+/[\d-b]/;
+/[\s-\d]/;
+/[\d-\s]/;
+/[a-[:digit:]]/;
+/[[:digit:]-b]/;
+/[[:alpha:]-[:digit:]]/;
+/[[:digit:]-[:alpha:]]/;
+EXPECT
+False [] range "a-\d" in regex; marked by <-- HERE in m/[a-\d <-- HERE ]/ at - line 5.
+False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE b]/ at - line 6.
+False [] range "\s-" in regex; marked by <-- HERE in m/[\s- <-- HERE \d]/ at - line 7.
+False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE \s]/ at - line 8.
+False [] range "a-[:digit:]" in regex; marked by <-- HERE in m/[a-[:digit:] <-- HERE ]/ at - line 9.
+False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE b]/ at - line 10.
+False [] range "[:alpha:]-" in regex; marked by <-- HERE in m/[[:alpha:]- <-- HERE [:digit:]]/ at - line 11.
+False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE [:alpha:]]/ at - line 12.
+########
+# regcomp.c [S_regclassutf8]
+BEGIN {
+    if (ord("\t") == 5) {
+        print "SKIPPED\n# ebcdic regular expression ranges differ.";
+        exit 0;
+    }
+}
+use utf8;
+$_ = "";
+use warnings 'regexp' ;
+/[a-b]/;
+/[a-\d]/;
+/[\d-b]/;
+/[\s-\d]/;
+/[\d-\s]/;
+/[a-[:digit:]]/;
+/[[:digit:]-b]/;
+/[[:alpha:]-[:digit:]]/;
+/[[:digit:]-[:alpha:]]/;
+no warnings 'regexp' ;
+/[a-b]/;
+/[a-\d]/;
+/[\d-b]/;
+/[\s-\d]/;
+/[\d-\s]/;
+/[a-[:digit:]]/;
+/[[:digit:]-b]/;
+/[[:alpha:]-[:digit:]]/;
+/[[:digit:]-[:alpha:]]/;
+EXPECT
+False [] range "a-\d" in regex; marked by <-- HERE in m/[a-\d <-- HERE ]/ at - line 12.
+False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE b]/ at - line 13.
+False [] range "\s-" in regex; marked by <-- HERE in m/[\s- <-- HERE \d]/ at - line 14.
+False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE \s]/ at - line 15.
+False [] range "a-[:digit:]" in regex; marked by <-- HERE in m/[a-[:digit:] <-- HERE ]/ at - line 16.
+False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE b]/ at - line 17.
+False [] range "[:alpha:]-" in regex; marked by <-- HERE in m/[[:alpha:]- <-- HERE [:digit:]]/ at - line 18.
+False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE [:alpha:]]/ at - line 19.
+########
+# regcomp.c [S_regclass S_regclassutf8]
+use warnings 'regexp' ;
+$a =~ /[a\zb]/ ;
+no warnings 'regexp' ;
+$a =~ /[a\zb]/ ;
+EXPECT
+Unrecognized escape \z in character class passed through in regex; marked by <-- HERE in m/[a\z <-- HERE b]/ at - line 3.
+
+########
+# regcomp.c [S_study_chunk]
+use warnings 'deprecated' ;
+$a = "xx" ;
+$a =~ /(?p{'x'})/ ;
+no warnings ;
+use warnings 'regexp' ;
+$a =~ /(?p{'x'})/ ;
+use warnings;
+no warnings 'deprecated' ;
+no warnings 'regexp' ;
+no warnings 'syntax' ;
+$a =~ /(?p{'x'})/ ;
+EXPECT
+(?p{}) is deprecated - use (??{}) in regex; marked by <-- HERE in m/(?p <-- HERE {'x'})/ at - line 4.
+(?p{}) is deprecated - use (??{}) in regex; marked by <-- HERE in m/(?p <-- HERE {'x'})/ at - line 7.
+########
+# regcomp.c [S_reg]
+use warnings 'regexp' ;
+$a = qr/(?c)/;
+$a = qr/(?-c)/;
+$a = qr/(?g)/;
+$a = qr/(?-g)/;
+$a = qr/(?o)/;
+$a = qr/(?-o)/;
+$a = qr/(?g-o)/;
+$a = qr/(?g-c)/;
+$a = qr/(?o-cg)/;  # (?c) means (?g) error won't be thrown
+$a = qr/(?ogc)/;
+no warnings 'regexp' ;
+$a = qr/(?c)/;
+$a = qr/(?-c)/;
+$a = qr/(?g)/;
+$a = qr/(?-g)/;
+$a = qr/(?o)/;
+$a = qr/(?-o)/;
+$a = qr/(?g-o)/;
+$a = qr/(?g-c)/;
+$a = qr/(?o-cg)/;  # (?c) means (?g) error won't be thrown
+$a = qr/(?ogc)/;
+#EXPECT
+EXPECT
+Useless (?c) - use /gc modifier in regex; marked by <-- HERE in m/(?c <-- HERE )/ at - line 3.
+Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?-c <-- HERE )/ at - line 4.
+Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE )/ at - line 5.
+Useless (?-g) - don't use /g modifier in regex; marked by <-- HERE in m/(?-g <-- HERE )/ at - line 6.
+Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE )/ at - line 7.
+Useless (?-o) - don't use /o modifier in regex; marked by <-- HERE in m/(?-o <-- HERE )/ at - line 8.
+Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE -o)/ at - line 9.
+Useless (?-o) - don't use /o modifier in regex; marked by <-- HERE in m/(?g-o <-- HERE )/ at - line 9.
+Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE -c)/ at - line 10.
+Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?g-c <-- HERE )/ at - line 10.
+Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE -cg)/ at - line 11.
+Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?o-c <-- HERE g)/ at - line 11.
+Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE gc)/ at - line 12.
+Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?og <-- HERE c)/ at - line 12.
+Useless (?c) - use /gc modifier in regex; marked by <-- HERE in m/(?ogc <-- HERE )/ at - line 12.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/regexec b/gnu/usr.bin/perl/t/lib/warnings/regexec
new file mode 100644
index 00000000000..73696dfb1d6
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/regexec
@@ -0,0 +1,119 @@
+  regexec.c	
+
+  This test generates "bad free" warnings when run under
+  PERL_DESTRUCT_LEVEL.  This file merely serves as a placeholder
+  for investigation.
+
+  Complex regular subexpression recursion limit (%d) exceeded
+
+        $_ = 'a' x (2**15+1); /^()(a\1)*$/ ;
+  Complex regular subexpression recursion limit (%d) exceeded
+
+        $_ = 'a' x (2**15+1); /^()(a\1)*?$/ ;
+
+  (The actual value substituted for %d is masked in the tests so that
+  REG_INFTY configuration variable value does not affect outcome.)
+__END__
+# regexec.c
+print("SKIPPED\n# most systems run into stacksize limits\n"),exit;
+use warnings 'regexp' ;
+$SIG{__WARN__} = sub{local ($m) = shift;
+                 $m =~ s/\(\d+\)/(*MASKED*)/;
+                 print STDERR $m};
+$_ = 'a' x (2**15+1); 
+/^()(a\1)*$/ ;
+#
+# If this test fails with a segmentation violation or similar,
+# you may have to increase the default stacksize limit in your
+# shell.  You may need superuser privileges.
+#
+# Under the sh, ksh, zsh:
+#    $ ulimit -s
+#    8192
+#    $ ulimit -s 16000
+#
+# Under the csh:
+#    % limit stacksize
+#    stacksize        8192 kbytes
+#    % limit stacksize 16000
+#
+EXPECT
+Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9.
+########
+# regexec.c
+print("SKIPPED\n# most systems run into stacksize limits\n"),exit;
+no warnings 'regexp' ;
+$SIG{__WARN__} = sub{local ($m) = shift;
+                 $m =~ s/\(\d+\)/(*MASKED*)/;
+                 print STDERR $m};
+$_ = 'a' x (2**15+1); 
+/^()(a\1)*$/ ;
+#
+# If this test fails with a segmentation violation or similar,
+# you may have to increase the default stacksize limit in your
+# shell.  You may need superuser privileges.
+#
+# Under the sh, ksh, zsh:
+#    $ ulimit -s
+#    8192
+#    $ ulimit -s 16000
+#
+# Under the csh:
+#    % limit stacksize
+#    stacksize        8192 kbytes
+#    % limit stacksize 16000
+#
+EXPECT
+
+########
+# regexec.c
+print("SKIPPED\n# most systems run into stacksize limits\n"),exit;
+use warnings 'regexp' ;
+$SIG{__WARN__} = sub{local ($m) = shift;
+                 $m =~ s/\(\d+\)/(*MASKED*)/;
+                 print STDERR $m};
+$_ = 'a' x (2**15+1);
+/^()(a\1)*?$/ ;
+#
+# If this test fails with a segmentation violation or similar,
+# you may have to increase the default stacksize limit in your
+# shell.  You may need superuser privileges.
+#
+# Under the sh, ksh, zsh:
+#    $ ulimit -s
+#    8192
+#    $ ulimit -s 16000
+#
+# Under the csh:
+#    % limit stacksize
+#    stacksize        8192 kbytes
+#    % limit stacksize 16000
+#
+EXPECT
+Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9.
+########
+# regexec.c
+print("SKIPPED\n# most systems run into stacksize limits\n"),exit;
+no warnings 'regexp' ;
+$SIG{__WARN__} = sub{local ($m) = shift;
+                 $m =~ s/\(\d+\)/(*MASKED*)/;
+                 print STDERR $m};
+$_ = 'a' x (2**15+1);
+/^()(a\1)*?$/ ;
+#
+# If this test fails with a segmentation violation or similar,
+# you may have to increase the default stacksize limit in your
+# shell.  You may need superuser privileges.
+#
+# Under the sh, ksh, zsh:
+#    $ ulimit -s
+#    8192
+#    $ ulimit -s 16000
+#
+# Under the csh:
+#    % limit stacksize
+#    stacksize        8192 kbytes
+#    % limit stacksize 16000
+#
+EXPECT
+
diff --git a/gnu/usr.bin/perl/t/lib/warnings/run b/gnu/usr.bin/perl/t/lib/warnings/run
new file mode 100644
index 00000000000..7a4be20e704
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/run
@@ -0,0 +1,8 @@
+  run.c 
+
+
+  Mandatory Warnings ALL TODO
+  ------------------
+        NULL OP IN RUN
+
+__END__
diff --git a/gnu/usr.bin/perl/t/lib/warnings/sv b/gnu/usr.bin/perl/t/lib/warnings/sv
new file mode 100644
index 00000000000..d9aa827fc8a
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/sv
@@ -0,0 +1,347 @@
+  sv.c	
+
+  warn(warn_uninit);
+
+  warn(warn_uninit);
+
+  warn(warn_uninit);
+
+  warn(warn_uninit);
+
+  not_a_number(sv);
+
+  not_a_number(sv);
+
+  warn(warn_uninit);
+
+  not_a_number(sv);
+
+  warn(warn_uninit);
+
+  not_a_number(sv);
+
+  not_a_number(sv);
+
+  warn(warn_uninit);
+
+  warn(warn_uninit);
+
+  Subroutine %s redefined	
+
+  Invalid conversion in %s:
+
+  Undefined value assigned to typeglob
+
+  Possible Y2K bug: %d format string following '19'
+
+  Reference is already weak			[Perl_sv_rvweaken] <<TODO
+
+  Mandatory Warnings
+  ------------------
+  Malformed UTF-8 character [sv_pos_b2u] (not tested: difficult to produce
+                                          with perl now)
+
+  Mandatory Warnings TODO
+  ------------------
+    Attempt to free non-arena SV: 0x%lx		[del_sv]
+    Reference miscount in sv_replace()		[sv_replace]
+    Attempt to free unreferenced scalar		[sv_free]
+    Attempt to free temp prematurely: SV 0x%lx	[sv_free]
+    semi-panic: attempt to dup freed string	[newSVsv]
+    
+
+__END__
+# sv.c
+use integer ;
+use warnings 'uninitialized' ;
+$x = 1 + $a[0] ; # a
+no warnings 'uninitialized' ;
+$x = 1 + $b[0] ; # a
+EXPECT
+Use of uninitialized value in integer addition (+) at - line 4.
+########
+# sv.c (sv_2iv)
+package fred ;
+sub TIESCALAR { my $x ; bless \$x}
+sub FETCH { return undef }
+sub STORE { return 1 }
+package main ;
+tie $A, 'fred' ;
+use integer ;
+use warnings 'uninitialized' ;
+$A *= 2 ;
+no warnings 'uninitialized' ;
+$A *= 2 ;
+EXPECT
+Use of uninitialized value in integer multiplication (*) at - line 10.
+########
+# sv.c
+use integer ;
+use warnings 'uninitialized' ;
+my $x *= 2 ; #b 
+no warnings 'uninitialized' ;
+my $y *= 2 ; #b 
+EXPECT
+Use of uninitialized value in integer multiplication (*) at - line 4.
+########
+# sv.c (sv_2uv)
+package fred ;
+sub TIESCALAR { my $x ; bless \$x}
+sub FETCH { return undef }
+sub STORE { return 1 }
+package main ;
+tie $A, 'fred' ;
+use warnings 'uninitialized' ;
+$B = 0 ;
+$B |= $A ;
+no warnings 'uninitialized' ;
+$B = 0 ;
+$B |= $A ;
+EXPECT
+Use of uninitialized value in bitwise or (|) at - line 10.
+########
+# sv.c
+use warnings 'uninitialized' ;
+my $Y = 1 ; 
+my $x = 1 | $a[$Y] ;
+no warnings 'uninitialized' ;
+my $Y = 1 ; 
+$x = 1 | $b[$Y] ;
+EXPECT
+Use of uninitialized value in bitwise or (|) at - line 4.
+########
+# sv.c
+use warnings 'uninitialized' ;
+my $x *= 1 ; # d
+no warnings 'uninitialized' ;
+my $y *= 1 ; # d
+EXPECT
+Use of uninitialized value in multiplication (*) at - line 3.
+########
+# sv.c
+use warnings 'uninitialized' ;
+$x = 1 + $a[0] ; # e
+no warnings 'uninitialized' ;
+$x = 1 + $b[0] ; # e
+EXPECT
+Use of uninitialized value in addition (+) at - line 3.
+########
+# sv.c (sv_2nv)
+package fred ;
+sub TIESCALAR { my $x ; bless \$x}
+sub FETCH { return undef }
+sub STORE { return 1 }
+package main ;
+tie $A, 'fred' ;
+use warnings 'uninitialized' ;
+$A *= 2 ;
+no warnings 'uninitialized' ;
+$A *= 2 ;
+EXPECT
+Use of uninitialized value in multiplication (*) at - line 9.
+########
+# sv.c
+use warnings 'uninitialized' ;
+$x = $y + 1 ; # f
+no warnings 'uninitialized' ;
+$x = $z + 1 ; # f
+EXPECT
+Use of uninitialized value in addition (+) at - line 3.
+########
+# sv.c
+use warnings 'uninitialized' ;
+$x = chop undef ; # g
+no warnings 'uninitialized' ;
+$x = chop undef ; # g
+EXPECT
+Modification of a read-only value attempted at - line 3.
+########
+# sv.c
+use warnings 'uninitialized' ;
+$x = chop $y ; # h
+no warnings 'uninitialized' ;
+$x = chop $z ; # h
+EXPECT
+Use of uninitialized value in scalar chop at - line 3.
+########
+# sv.c (sv_2pv)
+package fred ;
+sub TIESCALAR { my $x ; bless \$x}
+sub FETCH { return undef }
+sub STORE { return 1 }
+package main ;
+tie $A, 'fred' ;
+use warnings 'uninitialized' ;
+$B = "" ;
+$B .= $A ;
+no warnings 'uninitialized' ;
+$C = "" ;
+$C .= $A ;
+EXPECT
+Use of uninitialized value in concatenation (.) or string at - line 10.
+########
+# perlbug 20011116.125
+use warnings 'uninitialized';
+$a = undef;
+$foo = join '', $a, "\n";
+$foo = "$a\n";
+$foo = "a:$a\n";
+EXPECT
+Use of uninitialized value in join or string at - line 4.
+Use of uninitialized value in concatenation (.) or string at - line 5.
+Use of uninitialized value in concatenation (.) or string at - line 6.
+########
+# sv.c 
+use warnings 'numeric' ;
+sub TIESCALAR{bless[]} ; 
+sub FETCH {"def"} ; 
+tie $a,"main" ; 
+my $b = 1 + $a;
+no warnings 'numeric' ;
+my $c = 1 + $a;
+EXPECT
+Argument "def" isn't numeric in addition (+) at - line 6.
+########
+# sv.c
+use warnings 'numeric' ;
+my $x = 1 + "def" ;
+no warnings 'numeric' ;
+my $z = 1 + "def" ;
+EXPECT
+Argument "def" isn't numeric in addition (+) at - line 3.
+########
+# sv.c
+use warnings 'numeric' ;
+my $a = "def" ;
+my $x = 1 + $a ;
+no warnings 'numeric' ;
+my $y = 1 + $a ;
+EXPECT
+Argument "def" isn't numeric in addition (+) at - line 4.
+########
+# sv.c
+use warnings 'numeric' ; use integer ;
+my $a = "def" ;
+my $x = 1 + $a ;
+no warnings 'numeric' ;
+my $z = 1 + $a ;
+EXPECT
+Argument "def" isn't numeric in integer addition (+) at - line 4.
+########
+# sv.c
+use warnings 'numeric' ;
+my $x = 1 & "def" ;
+no warnings 'numeric' ;
+my $z = 1 & "def" ;
+EXPECT
+Argument "def" isn't numeric in bitwise and (&) at - line 3.
+########
+# sv.c
+use warnings 'numeric' ;
+my $x = pack i => "def" ;
+no warnings 'numeric' ;
+my $z = pack i => "def" ;
+EXPECT
+Argument "def" isn't numeric in pack at - line 3.
+########
+# sv.c
+use warnings 'numeric' ; 
+my $a = "d\0f" ;
+my $x = 1 + $a ;
+no warnings 'numeric' ;
+my $z = 1 + $a ;
+EXPECT
+Argument "d\0f" isn't numeric in addition (+) at - line 4.
+########
+# sv.c
+use warnings 'redefine' ;
+sub fred {}  
+sub joe {} 
+*fred = \&joe ;
+no warnings 'redefine' ;
+sub jim {} 
+*jim = \&joe ;
+EXPECT
+Subroutine main::fred redefined at - line 5.
+########
+# sv.c
+use warnings 'printf' ;
+open F, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ;
+printf F "%z\n" ;
+my $a = sprintf "%z" ;
+printf F "%" ;
+$a = sprintf "%" ;
+printf F "%\x02" ;
+$a = sprintf "%\x02" ;
+no warnings 'printf' ;
+printf F "%z\n" ;
+$a = sprintf "%z" ;
+printf F "%" ;
+$a = sprintf "%" ;
+printf F "%\x02" ;
+$a = sprintf "%\x02" ;
+EXPECT
+Invalid conversion in sprintf: "%z" at - line 5.
+Invalid conversion in sprintf: end of string at - line 7.
+Invalid conversion in sprintf: "%\002" at - line 9.
+Invalid conversion in printf: "%z" at - line 4.
+Invalid conversion in printf: end of string at - line 6.
+Invalid conversion in printf: "%\002" at - line 8.
+########
+# sv.c
+use warnings 'misc' ;
+*a = undef ;
+no warnings 'misc' ;
+*b = undef ;
+EXPECT
+Undefined value assigned to typeglob at - line 3.
+########
+# sv.c
+use warnings 'y2k';
+use Config;
+BEGIN {
+    unless ($Config{ccflags} =~ /Y2KWARN/) {
+	print "SKIPPED\n# perl not built with -DPERL_Y2KWARN";
+	exit 0;
+    }
+    $|=1;
+}
+my $x;
+my $yy = 78;
+$x     = printf  "19%02d\n", $yy;
+$x     = sprintf "#19%02d\n", $yy;
+$x     = printf  " 19%02d\n", 78;
+$x     = sprintf "19%02d\n", 78;
+$x     = printf  "319%02d\n", $yy;
+$x     = sprintf "319%02d\n", $yy;
+no warnings 'y2k';
+$x     = printf  "19%02d\n", $yy;
+$x     = sprintf "19%02d\n", $yy;
+$x     = printf  "19%02d\n", 78;
+$x     = sprintf "19%02d\n", 78;
+EXPECT
+Possible Y2K bug: %d format string following '19' at - line 16.
+Possible Y2K bug: %d format string following '19' at - line 13.
+1978
+Possible Y2K bug: %d format string following '19' at - line 14.
+Possible Y2K bug: %d format string following '19' at - line 15.
+ 1978
+31978
+1978
+1978
+########
+# sv.c
+use warnings 'numeric' ;
+$a = "\x{100}\x{200}" * 42;
+no warnings 'numeric' ;
+$a = "\x{100}\x{200}" * 42;
+EXPECT
+Argument "\x{100}\x{200}" isn't numeric in multiplication (*) at - line 3.
+########
+# sv.c
+use warnings 'numeric' ;
+$a = "\x{100}\x{200}"; $a = -$a;
+no warnings 'numeric' ;
+$a = "\x{100}\x{200}"; $a = -$a;
+EXPECT
+Argument "\x{100}\x{200}" isn't numeric in negation (-) at - line 3.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/taint b/gnu/usr.bin/perl/t/lib/warnings/taint
new file mode 100644
index 00000000000..fd6deed60f9
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/taint
@@ -0,0 +1,49 @@
+  taint.c AOK
+
+  Insecure %s%s while running with -T switch
+
+__END__
+-T
+--FILE-- abc
+def
+--FILE--
+# taint.c
+open(FH, "<abc") ;
+$a = <FH> ;
+close FH ;
+chdir $a ;
+print "xxx\n" ;
+EXPECT
+Insecure dependency in chdir while running with -T switch at - line 5.
+########
+-TU
+--FILE-- abc
+def
+--FILE--
+# taint.c
+open(FH, "<abc") ;
+$a = <FH> ;
+close FH ;
+chdir $a ;
+print "xxx\n" ;
+EXPECT
+xxx
+########
+-TU
+--FILE-- abc
+def
+--FILE--
+# taint.c
+open(FH, "<abc") ;
+$a = <FH> ;
+close FH ;
+use warnings 'taint' ;
+chdir $a ;
+print "xxx\n" ;
+no warnings 'taint' ;
+chdir $a ;
+print "yyy\n" ;
+EXPECT
+Insecure dependency in chdir while running with -T switch at - line 6.
+xxx
+yyy
diff --git a/gnu/usr.bin/perl/t/lib/warnings/toke b/gnu/usr.bin/perl/t/lib/warnings/toke
new file mode 100644
index 00000000000..0a5346a50f8
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/toke
@@ -0,0 +1,798 @@
+toke.c	AOK
+
+    we seem to have lost a few ambiguous warnings!!
+
+ 
+ 		$a = <<;
+ 		Use of comma-less variable list is deprecated 
+		(called 3 times via depcom)
+
+     \1 better written as $1 
+ 	use warnings 'syntax' ;
+ 	s/(abc)/\1/;
+ 
+     warn(warn_nosemi) 
+     Semicolon seems to be missing
+	$a = 1
+	&time ;
+
+
+     Reversed %c= operator 
+	my $a =+ 2 ;
+	$a =- 2 ;
+	$a =* 2 ;
+	$a =% 2 ;
+	$a =& 2 ;
+	$a =. 2 ;
+	$a =^ 2 ;
+	$a =| 2 ;
+	$a =< 2 ;
+	$a =/ 2 ;
+
+     Multidimensional syntax %.*s not supported 
+	my $a = $a[1,2] ;
+
+     You need to quote \"%s\"" 
+	sub fred {} ; $SIG{TERM} = fred;
+
+     Scalar value %.*s better written as $%.*s" 
+	@a[3] = 2;
+	@a{3} = 2;
+
+     Can't use \\%c to mean $%c in expression 
+	$_ = "ab" ; s/(ab)/\1/e;
+
+     Unquoted string "abc" may clash with future reserved word at - line 3.
+     warn(warn_reserved	
+	$a = abc;
+
+     Possible attempt to separate words with commas 
+	@a = qw(a, b, c) ;
+
+     Possible attempt to put comments in qw() list 
+	@a = qw(a b # c) ;
+
+     %s (...) interpreted as function 
+	print ("")
+	printf ("")
+	sort ("")
+
+     Ambiguous use of %c{%s%s} resolved to %c%s%s 
+	$a = ${time[2]}
+	$a = ${time{2}}
+
+
+     Ambiguous use of %c{%s} resolved to %c%s
+	$a = ${time}
+	sub fred {} $a = ${fred}
+
+     Misplaced _ in number 
+	$a = 1_2;
+	$a = 1_2345_6;
+
+    Bareword \"%s\" refers to nonexistent package
+	$a = FRED:: ;
+
+    Ambiguous call resolved as CORE::%s(), qualify as such or use &
+	sub time {} 
+	my $a = time()
+
+    Unrecognized escape \\%c passed through
+        $a = "\m" ;
+
+    %s number > %s non-portable
+        my $a =  0b011111111111111111111111111111110 ;
+        $a =  0b011111111111111111111111111111111 ;
+        $a =  0b111111111111111111111111111111111 ;
+        $a =  0x0fffffffe ;
+        $a =  0x0ffffffff ;
+        $a =  0x1ffffffff ;
+        $a =  0037777777776 ;
+        $a =  0037777777777 ;
+        $a =  0047777777777 ;
+
+    Integer overflow in binary number
+        my $a =  0b011111111111111111111111111111110 ;
+        $a =  0b011111111111111111111111111111111 ;
+        $a =  0b111111111111111111111111111111111 ;
+        $a =  0x0fffffffe ;
+        $a =  0x0ffffffff ;
+        $a =  0x1ffffffff ;
+        $a =  0037777777776 ;
+        $a =  0037777777777 ;
+        $a =  0047777777777 ;
+
+    dump() better written as CORE::dump()
+
+    Use of /c modifier is meaningless without /g     
+
+    Use of /c modifier is meaningless in s///
+
+    Mandatory Warnings
+    ------------------
+    Use of "%s" without parentheses is ambiguous	[check_uni]
+        rand + 4 
+
+    Ambiguous use of -%s resolved as -&%s() 		[yylex]
+        sub fred {} ; - fred ;
+
+    Precedence problem: open %.*s should be open(%.*s)	[yylex]
+    	open FOO || die;
+
+    Operator or semicolon missing before %c%s		[yylex]
+    Ambiguous use of %c resolved as operator %c
+        *foo *foo
+
+__END__
+# toke.c 
+use warnings 'deprecated' ;
+format STDOUT =
+@<<<  @|||  @>>>  @>>>
+$a    $b    "abc" 'def'
+.
+no warnings 'deprecated' ;
+format STDOUT =
+@<<<  @|||  @>>>  @>>>
+$a    $b    "abc" 'def'
+.
+EXPECT
+Use of comma-less variable list is deprecated at - line 5.
+Use of comma-less variable list is deprecated at - line 5.
+Use of comma-less variable list is deprecated at - line 5.
+########
+# toke.c
+use warnings 'deprecated' ;
+$a = <<;
+
+no warnings 'deprecated' ;
+$a = <<;
+
+EXPECT
+Use of bare << to mean <<"" is deprecated at - line 3.
+########
+# toke.c
+use warnings 'syntax' ;
+s/(abc)/\1/;
+no warnings 'syntax' ;
+s/(abc)/\1/;
+EXPECT
+\1 better written as $1 at - line 3.
+########
+# toke.c
+use warnings 'semicolon' ;
+$a = 1
+&time ;
+no warnings 'semicolon' ;
+$a = 1
+&time ;
+EXPECT
+Semicolon seems to be missing at - line 3.
+########
+# toke.c
+use warnings 'syntax' ;
+my $a =+ 2 ;
+$a =- 2 ;
+$a =* 2 ;
+$a =% 2 ;
+$a =& 2 ;
+$a =. 2 ;
+$a =^ 2 ;
+$a =| 2 ;
+$a =< 2 ;
+$a =/ 2 ;
+EXPECT
+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 ;
+$a =* 2 ;
+$a =% 2 ;
+$a =& 2 ;
+$a =. 2 ;
+$a =^ 2 ;
+$a =| 2 ;
+$a =< 2 ;
+$a =/ 2 ;
+EXPECT
+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' ;
+my $a = $a[1,2] ;
+no warnings 'syntax' ;
+my $a = $a[1,2] ;
+EXPECT
+Multidimensional syntax $a[1,2] not supported at - line 3.
+########
+# toke.c
+use warnings 'syntax' ;
+sub fred {} ; $SIG{TERM} = fred;
+no warnings 'syntax' ;
+$SIG{TERM} = fred;
+EXPECT
+You need to quote "fred" at - line 3.
+########
+# toke.c
+use warnings 'syntax' ;
+@a[3] = 2;
+@a{3} = 2;
+no warnings 'syntax' ;
+@a[3] = 2;
+@a{3} = 2;
+EXPECT
+Scalar value @a[3] better written as $a[3] at - line 3.
+Scalar value @a{3} better written as $a{3} at - line 4.
+########
+# toke.c
+use warnings 'syntax' ;
+$_ = "ab" ; 
+s/(ab)/\1/e;
+no warnings 'syntax' ;
+$_ = "ab" ; 
+s/(ab)/\1/e;
+EXPECT
+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
+Unquoted string "abc" may clash with future reserved word at - line 3.
+########
+# toke.c
+use warnings 'qw' ;
+@a = qw(a, b, c) ;
+no warnings 'qw' ;
+@a = qw(a, b, c) ;
+EXPECT
+Possible attempt to separate words with commas at - line 3.
+########
+# toke.c
+use warnings 'qw' ;
+@a = qw(a b #) ;
+no warnings 'qw' ;
+@a = qw(a b #) ;
+EXPECT
+Possible attempt to put comments in qw() list at - line 3.
+########
+# toke.c
+use warnings 'syntax' ;
+print ("")
+EXPECT
+print (...) interpreted as function at - line 3.
+########
+# toke.c
+no warnings 'syntax' ;
+print ("")
+EXPECT
+
+########
+# toke.c
+use warnings 'syntax' ;
+printf ("")
+EXPECT
+printf (...) interpreted as function at - line 3.
+########
+# toke.c
+no warnings 'syntax' ;
+printf ("")
+EXPECT
+
+########
+# toke.c
+use warnings 'syntax' ;
+sort ("")
+EXPECT
+sort (...) interpreted as function at - line 3.
+########
+# toke.c
+no warnings 'syntax' ;
+sort ("")
+EXPECT
+
+########
+# toke.c
+use warnings 'ambiguous' ;
+$a = ${time[2]};
+no warnings 'ambiguous' ;
+$a = ${time[2]};
+EXPECT
+Ambiguous use of ${time[...]} resolved to $time[...] at - line 3.
+########
+# toke.c
+use warnings 'ambiguous' ;
+$a = ${time{2}};
+EXPECT
+Ambiguous use of ${time{...}} resolved to $time{...} at - line 3.
+########
+# toke.c
+no warnings 'ambiguous' ;
+$a = ${time{2}};
+EXPECT
+
+########
+# toke.c
+use warnings 'ambiguous' ;
+$a = ${time} ;
+no warnings 'ambiguous' ;
+$a = ${time} ;
+EXPECT
+Ambiguous use of ${time} resolved to $time at - line 3.
+########
+# toke.c
+use warnings 'ambiguous' ;
+sub fred {}
+$a = ${fred} ;
+no warnings 'ambiguous' ;
+$a = ${fred} ;
+EXPECT
+Ambiguous use of ${fred} resolved to $fred at - line 4.
+########
+# toke.c
+use warnings 'syntax' ;
+$a = _123; print "$a\n";		#( 3	string)
+$a = 1_23; print "$a\n";
+$a = 12_3; print "$a\n";
+$a = 123_; print "$a\n";		#  6
+$a = _+123; print "$a\n";		#  7	string)
+$a = +_123; print "$a\n";		#( 8	string)
+$a = +1_23; print "$a\n";
+$a = +12_3; print "$a\n";
+$a = +123_; print "$a\n";		# 11
+$a = _-123; print "$a\n";		#(12	string)
+$a = -_123; print "$a\n";		#(13	string)
+$a = -1_23; print "$a\n";
+$a = -12_3; print "$a\n";
+$a = -123_; print "$a\n";		# 16
+$a = 123._456; print "$a\n";		# 17
+$a = 123.4_56; print "$a\n";
+$a = 123.45_6; print "$a\n";
+$a = 123.456_; print "$a\n";		# 20
+$a = +123._456; print "$a\n";		# 21
+$a = +123.4_56; print "$a\n";	
+$a = +123.45_6; print "$a\n";	
+$a = +123.456_; print "$a\n";		# 24
+$a = -123._456; print "$a\n";		# 25
+$a = -123.4_56; print "$a\n";	
+$a = -123.45_6; print "$a\n";
+$a = -123.456_; print "$a\n";		# 28
+$a = 123.456E_12; printf("%.0f\n", $a);	# 29
+$a = 123.456E1_2; printf("%.0f\n", $a);
+$a = 123.456E12_; printf("%.0f\n", $a);	# 31
+$a = 123.456E_+12; printf("%.0f\n", $a);	# 32
+$a = 123.456E+_12; printf("%.0f\n", $a);	# 33
+$a = 123.456E+1_2; printf("%.0f\n", $a);
+$a = 123.456E+12_; printf("%.0f\n", $a);	# 35
+$a = 123.456E_-12; print "$a\n";	# 36
+$a = 123.456E-_12; print "$a\n";	# 37
+$a = 123.456E-1_2; print "$a\n";
+$a = 123.456E-12_; print "$a\n";	# 39
+$a = 1__23; print "$a\n";		# 40
+$a = 12.3__4; print "$a\n";		# 41
+$a = 12.34e1__2; printf("%.0f\n", $a);	# 42
+no warnings 'syntax' ;
+$a = _123; print "$a\n";
+$a = 1_23; print "$a\n";
+$a = 12_3; print "$a\n";
+$a = 123_; print "$a\n";
+$a = _+123; print "$a\n";
+$a = +_123; print "$a\n";
+$a = +1_23; print "$a\n";
+$a = +12_3; print "$a\n";
+$a = +123_; print "$a\n";
+$a = _-123; print "$a\n";
+$a = -_123; print "$a\n";
+$a = -1_23; print "$a\n";
+$a = -12_3; print "$a\n";
+$a = -123_; print "$a\n";
+$a = 123._456; print "$a\n";
+$a = 123.4_56; print "$a\n";
+$a = 123.45_6; print "$a\n";
+$a = 123.456_; print "$a\n";
+$a = +123._456; print "$a\n";
+$a = +123.4_56; print "$a\n";
+$a = +123.45_6; print "$a\n";
+$a = +123.456_; print "$a\n";
+$a = -123._456; print "$a\n";
+$a = -123.4_56; print "$a\n";
+$a = -123.45_6; print "$a\n";
+$a = -123.456_; print "$a\n";
+$a = 123.456E_12; printf("%.0f\n", $a);
+$a = 123.456E1_2; printf("%.0f\n", $a);
+$a = 123.456E12_; printf("%.0f\n", $a);
+$a = 123.456E_+12; printf("%.0f\n", $a);
+$a = 123.456E+_12; printf("%.0f\n", $a);
+$a = 123.456E+1_2; printf("%.0f\n", $a);
+$a = 123.456E+12_; printf("%.0f\n", $a);
+$a = 123.456E_-12; print "$a\n";
+$a = 123.456E-_12; print "$a\n";
+$a = 123.456E-1_2; print "$a\n";
+$a = 123.456E-12_; print "$a\n";
+$a = 1__23; print "$a\n";
+$a = 12.3__4; print "$a\n";
+$a = 12.34e1__2; printf("%.0f\n", $a);
+EXPECT
+OPTIONS regex
+Misplaced _ in number at - line 6.
+Misplaced _ in number at - line 11.
+Misplaced _ in number at - line 16.
+Misplaced _ in number at - line 17.
+Misplaced _ in number at - line 20.
+Misplaced _ in number at - line 21.
+Misplaced _ in number at - line 24.
+Misplaced _ in number at - line 25.
+Misplaced _ in number at - line 28.
+Misplaced _ in number at - line 29.
+Misplaced _ in number at - line 31.
+Misplaced _ in number at - line 32.
+Misplaced _ in number at - line 33.
+Misplaced _ in number at - line 35.
+Misplaced _ in number at - line 36.
+Misplaced _ in number at - line 37.
+Misplaced _ in number at - line 39.
+Misplaced _ in number at - line 40.
+Misplaced _ in number at - line 41.
+Misplaced _ in number at - line 42.
+_123
+123
+123
+123
+123
+_123
+123
+123
+123
+-123
+-_123
+-123
+-123
+-123
+123.456
+123.456
+123.456
+123.456
+123.456
+123.456
+123.456
+123.456
+-123.456
+-123.456
+-123.456
+-123.456
+123456000000000
+123456000000000
+123456000000000
+123456000000000
+123456000000000
+123456000000000
+123456000000000
+1.23456e-0?10
+1.23456e-0?10
+1.23456e-0?10
+1.23456e-0?10
+123
+12.34
+12340000000000
+_123
+123
+123
+123
+123
+_123
+123
+123
+123
+-123
+-_123
+-123
+-123
+-123
+123.456
+123.456
+123.456
+123.456
+123.456
+123.456
+123.456
+123.456
+-123.456
+-123.456
+-123.456
+-123.456
+123456000000000
+123456000000000
+123456000000000
+123456000000000
+123456000000000
+123456000000000
+123456000000000
+1.23456e-0?10
+1.23456e-0?10
+1.23456e-0?10
+1.23456e-0?10
+123
+12.34
+12340000000000
+########
+# toke.c
+use warnings 'bareword' ;
+#line 25 "bar"
+$a = FRED:: ;
+no warnings 'bareword' ;
+#line 25 "bar"
+$a = FRED:: ;
+EXPECT
+Bareword "FRED::" refers to nonexistent package at bar line 25.
+########
+# toke.c
+use warnings 'ambiguous' ;
+sub time {}
+my $a = time() ;
+no warnings 'ambiguous' ;
+my $b = time() ;
+EXPECT
+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";
+{
+  $_ = " \x{123} " ;
+}
+EOE
+EXPECT
+yelp at foo line 30.
+########
+# toke.c
+my $a = rand + 4 ;
+EXPECT
+Warning: Use of "rand" without parens is ambiguous at - line 2.
+########
+# toke.c
+$^W = 0 ;
+my $a = rand + 4 ;
+{
+    no warnings 'ambiguous' ;
+    $a = rand + 4 ;
+    use warnings 'ambiguous' ;
+    $a = rand + 4 ;
+}
+$a = rand + 4 ;
+EXPECT
+Warning: Use of "rand" without parens is ambiguous at - line 3.
+Warning: Use of "rand" without parens is ambiguous at - line 8.
+Warning: Use of "rand" without parens is ambiguous at - line 10.
+########
+# toke.c
+sub fred {};
+-fred ;
+EXPECT
+Ambiguous use of -fred resolved as -&fred() at - line 3.
+########
+# toke.c
+$^W = 0 ;
+sub fred {} ;
+-fred ;
+{
+    no warnings 'ambiguous' ;
+    -fred ;
+    use warnings 'ambiguous' ;
+    -fred ;
+}
+-fred ;
+EXPECT
+Ambiguous use of -fred resolved as -&fred() at - line 4.
+Ambiguous use of -fred resolved as -&fred() at - line 9.
+Ambiguous use of -fred resolved as -&fred() at - line 11.
+########
+# toke.c
+open FOO || time;
+EXPECT
+Precedence problem: open FOO should be open(FOO) at - line 2.
+########
+# toke.c
+$^W = 0 ;
+open FOO || time;
+{
+    no warnings 'precedence' ;
+    open FOO || time;
+    use warnings 'precedence' ;
+    open FOO || time;
+}
+open FOO || time;
+EXPECT
+Precedence problem: open FOO should be open(FOO) at - line 3.
+Precedence problem: open FOO should be open(FOO) at - line 8.
+Precedence problem: open FOO should be open(FOO) at - line 10.
+########
+# toke.c
+$^W = 0 ;
+*foo *foo ;
+{
+    no warnings 'ambiguous' ;
+    *foo *foo ;
+    use warnings 'ambiguous' ;
+    *foo *foo ;
+}
+*foo *foo ;
+EXPECT
+Operator or semicolon missing before *foo at - line 3.
+Ambiguous use of * resolved as operator * at - line 3.
+Operator or semicolon missing before *foo at - line 8.
+Ambiguous use of * resolved as operator * at - line 8.
+Operator or semicolon missing before *foo at - line 10.
+Ambiguous use of * resolved as operator * at - line 10.
+########
+# toke.c
+use warnings 'misc' ;
+my $a = "\m" ;
+no warnings 'misc' ;
+$a = "\m" ;
+EXPECT
+Unrecognized escape \m passed through at - line 3.
+########
+# toke.c
+use warnings 'portable' ;
+my $a =  0b011111111111111111111111111111110 ;
+   $a =  0b011111111111111111111111111111111 ;
+   $a =  0b111111111111111111111111111111111 ;
+   $a =  0x0fffffffe ;
+   $a =  0x0ffffffff ;
+   $a =  0x1ffffffff ;
+   $a =  0037777777776 ;
+   $a =  0037777777777 ;
+   $a =  0047777777777 ;
+no warnings 'portable' ;
+   $a =  0b011111111111111111111111111111110 ;
+   $a =  0b011111111111111111111111111111111 ;
+   $a =  0b111111111111111111111111111111111 ;
+   $a =  0x0fffffffe ;
+   $a =  0x0ffffffff ;
+   $a =  0x1ffffffff ;
+   $a =  0037777777776 ;
+   $a =  0037777777777 ;
+   $a =  0047777777777 ;
+EXPECT
+Binary number > 0b11111111111111111111111111111111 non-portable at - line 5.
+Hexadecimal number > 0xffffffff non-portable at - line 8.
+Octal number > 037777777777 non-portable at - line 11.
+########
+# toke.c
+use warnings 'overflow' ;
+my $a =  0b011111111111111111111111111111110 ;
+   $a =  0b011111111111111111111111111111111 ;
+   $a =  0b10000000000000000000000000000000000000000000000000000000000000000 ;
+   $a =  0x0fffffffe ;
+   $a =  0x0ffffffff ;
+   $a =  0x10000000000000000 ;
+   $a =  0037777777776 ;
+   $a =  0037777777777 ;
+   $a =  002000000000000000000000;
+no warnings 'overflow' ;
+   $a =  0b011111111111111111111111111111110 ;
+   $a =  0b011111111111111111111111111111111 ;
+   $a =  0b10000000000000000000000000000000000000000000000000000000000000000 ;
+   $a =  0x0fffffffe ;
+   $a =  0x0ffffffff ;
+   $a =  0x10000000000000000 ;
+   $a =  0037777777776 ;
+   $a =  0037777777777 ;
+   $a =  002000000000000000000000;
+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
+BEGIN { $^C = 1; }
+use warnings 'misc';
+dump;
+CORE::dump;
+EXPECT
+dump() better written as CORE::dump() at - line 4.
+- syntax OK
+########
+# toke.c
+use warnings 'misc';
+use subs qw/dump/;
+sub dump { print "no warning for overriden dump\n"; }
+dump;
+EXPECT
+no warning for overriden dump
+########
+# 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.
+########
+# toke.c
+# The \q should warn, the \_ should NOT warn.
+use warnings 'misc';
+"foo" =~ /\q/;
+"bar" =~ /\_/;
+no warnings 'misc';
+"foo" =~ /\q/;
+"bar" =~ /\_/;
+EXPECT
+Unrecognized escape \q passed through at - line 4.
+########
+# toke.c
+# 20020328 mjd-perl-patch+@plover.com at behest of jfriedl@yahoo.com
+use warnings 'regexp';
+"foo" =~ /foo/c;
+"foo" =~ /foo/cg;
+no warnings 'regexp';
+"foo" =~ /foo/c;
+"foo" =~ /foo/cg;
+EXPECT
+Use of /c modifier is meaningless without /g at - line 4.
+########
+# toke.c
+# 20020328 mjd-perl-patch+@plover.com at behest of jfriedl@yahoo.com
+use warnings 'regexp';
+$_ = "ab" ; 
+s/ab/ab/c;
+s/ab/ab/cg;
+no warnings 'regexp';
+s/ab/ab/c;
+s/ab/ab/cg;
+EXPECT
+Use of /c modifier is meaningless in s/// at - line 5.
+Use of /c modifier is meaningless in s/// at - line 6.
+########
+-wa
+# toke.c
+# 20020414 mjd-perl-patch+@plover.com # -a flag should suppress these warnings
+print "@F\n";
+EXPECT
+
+########
+-w
+# toke.c
+# 20020414 mjd-perl-patch+@plover.com # -a flag should suppress these warnings
+print "@F\n";
+EXPECT
+Possible unintended interpolation of @F in string at - line 4.
+Name "main::F" used only once: possible typo at - line 4.
+########
+-wa
+# toke.c
+# 20020414 mjd-perl-patch+@plover.com
+EXPECT
+
+########
+# toke.c
+# 20020414 mjd-perl-patch+@plover.com
+# In 5.7.3, this emitted "Possible unintended interpolation" warnings
+use warnings 'ambiguous';
+$s = "(@-)(@+)";
+EXPECT
+
+
diff --git a/gnu/usr.bin/perl/t/lib/warnings/universal b/gnu/usr.bin/perl/t/lib/warnings/universal
new file mode 100644
index 00000000000..d9b1883532d
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/universal
@@ -0,0 +1,14 @@
+  universal.c AOK
+
+  Can't locate package %s for @%s::ISA	[S_isa_lookup]
+      
+
+
+__END__
+# universal.c [S_isa_lookup]
+use warnings 'misc' ;
+@ISA = qw(Joe) ;
+my $a = bless [] ;
+UNIVERSAL::isa $a, Jim ;
+EXPECT
+Can't locate package Joe for @main::ISA at - line 5.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/utf8 b/gnu/usr.bin/perl/t/lib/warnings/utf8
new file mode 100644
index 00000000000..6635f02d755
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/utf8
@@ -0,0 +1,136 @@
+
+  utf8.c AOK
+
+     [utf8_to_uv]
+     Malformed UTF-8 character
+	my $a = ord "\x80" ;
+
+     Malformed UTF-8 character
+	my $a = ord "\xf080" ;
+     <<<<<< this warning can't be easily triggered from perl anymore
+
+     [utf16_to_utf8]
+     Malformed UTF-16 surrogate		
+     <<<<<< Add a test when somethig actually calls utf16_to_utf8
+
+__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" ;
+{
+    no warnings 'utf8' ;
+    my $a = "snøstorm";
+    use warnings 'utf8' ;
+    my $a = "snøstorm";
+}
+EXPECT
+Malformed UTF-8 character (unexpected non-continuation byte 0x73, immediately after start byte 0xf8) at - line 9.
+Malformed UTF-8 character (unexpected non-continuation byte 0x73, immediately after start byte 0xf8) at - line 14.
+########
+use warnings 'utf8';
+my $d7ff  = chr(0xD7FF);
+my $d800  = chr(0xD800);
+my $dfff  = chr(0xDFFF);
+my $e000  = chr(0xE000);
+my $feff  = chr(0xFEFF);
+my $fffd  = chr(0xFFFD);
+my $fffe  = chr(0xFFFE);
+my $ffff  = chr(0xFFFF);
+my $hex4  = chr(0x10000);
+my $hex5  = chr(0x100000);
+my $maxm1 = chr(0x10FFFE);
+my $max   = chr(0x10FFFF);
+no warnings 'utf8';
+my $d7ff  = chr(0xD7FF);
+my $d800  = chr(0xD800);
+my $dfff  = chr(0xDFFF);
+my $e000  = chr(0xE000);
+my $feff  = chr(0xFEFF);
+my $fffd  = chr(0xFFFD);
+my $fffe  = chr(0xFFFE);
+my $ffff  = chr(0xFFFF);
+my $hex4  = chr(0x10000);
+my $hex5  = chr(0x100000);
+my $maxm1 = chr(0x10FFFE);
+my $max   = chr(0x10FFFF);
+EXPECT
+UTF-16 surrogate 0xd800 at - line 3.
+UTF-16 surrogate 0xdfff at - line 4.
+Unicode character 0xfffe is illegal at - line 8.
+Unicode character 0xffff is illegal at - line 9.
+Unicode character 0x10fffe is illegal at - line 12.
+Unicode character 0x10ffff is illegal at - line 13.
+########
+use warnings 'utf8';
+my $d7ff  = pack("U", 0xD7FF);
+my $d800  = pack("U", 0xD800);
+my $dfff  = pack("U", 0xDFFF);
+my $e000  = pack("U", 0xE000);
+my $feff  = pack("U", 0xFEFF);
+my $fffd  = pack("U", 0xFFFD);
+my $fffe  = pack("U", 0xFFFE);
+my $ffff  = pack("U", 0xFFFF);
+my $hex4  = pack("U", 0x10000);
+my $hex5  = pack("U", 0x100000);
+my $maxm1 = pack("U", 0x10FFFE);
+my $max   = pack("U", 0x10FFFF);
+no warnings 'utf8';
+my $d7ff  = pack("U", 0xD7FF);
+my $d800  = pack("U", 0xD800);
+my $dfff  = pack("U", 0xDFFF);
+my $e000  = pack("U", 0xE000);
+my $feff  = pack("U", 0xFEFF);
+my $fffd  = pack("U", 0xFFFD);
+my $fffe  = pack("U", 0xFFFE);
+my $ffff  = pack("U", 0xFFFF);
+my $hex4  = pack("U", 0x10000);
+my $hex5  = pack("U", 0x100000);
+my $maxm1 = pack("U", 0x10FFFE);
+my $max   = pack("U", 0x10FFFF);
+EXPECT
+UTF-16 surrogate 0xd800 at - line 3.
+UTF-16 surrogate 0xdfff at - line 4.
+Unicode character 0xfffe is illegal at - line 8.
+Unicode character 0xffff is illegal at - line 9.
+Unicode character 0x10fffe is illegal at - line 12.
+Unicode character 0x10ffff is illegal at - line 13.
+########
+use warnings 'utf8';
+my $d7ff  = "\x{D7FF}";
+my $d800  = "\x{D800}";
+my $dfff  = "\x{DFFF}";
+my $e000  = "\x{E000}";
+my $feff  = "\x{FEFF}";
+my $fffd  = "\x{FFFD}";
+my $fffe  = "\x{FFFE}";
+my $ffff  = "\x{FFFF}";
+my $hex4  = "\x{10000}";
+my $hex5  = "\x{100000}";
+my $maxm1 = "\x{10FFFE}";
+my $max   = "\x{10FFFF}";
+no warnings 'utf8';
+my $d7ff  = "\x{D7FF}";
+my $d800  = "\x{D800}";
+my $dfff  = "\x{DFFF}";
+my $e000  = "\x{E000}";
+my $feff  = "\x{FEFF}";
+my $fffd  = "\x{FFFD}";
+my $fffe  = "\x{FFFE}";
+my $ffff  = "\x{FFFF}";
+my $hex4  = "\x{10000}";
+my $hex5  = "\x{100000}";
+my $maxm1 = "\x{10FFFE}";
+my $max   = "\x{10FFFF}";
+EXPECT
+UTF-16 surrogate 0xd800 at - line 3.
+UTF-16 surrogate 0xdfff at - line 4.
+Unicode character 0xfffe is illegal at - line 8.
+Unicode character 0xffff is illegal at - line 9.
+Unicode character 0x10fffe is illegal at - line 12.
+Unicode character 0x10ffff is illegal at - line 13.
diff --git a/gnu/usr.bin/perl/t/lib/warnings/util b/gnu/usr.bin/perl/t/lib/warnings/util
new file mode 100644
index 00000000000..4e960c1ea19
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/warnings/util
@@ -0,0 +1,158 @@
+  util.c AOK
+ 
+     Illegal octal digit ignored 
+	my $a = oct "029" ;
+
+     Illegal hex digit ignored 
+	my $a = hex "0xv9" ;
+
+     Illegal binary digit ignored
+      my $a = oct "0b9" ;
+     
+     Integer overflow in binary number
+	my $a =  oct "0b111111111111111111111111111111111111111111" ;
+     Binary number > 0b11111111111111111111111111111111 non-portable
+   	$a =  oct "0b111111111111111111111111111111111" ;
+     Integer overflow in octal number
+	my $a =  oct "077777777777777777777777777777" ;
+     Octal number > 037777777777 non-portable
+   	$a =  oct "0047777777777" ;
+     Integer overflow in hexadecimal number
+	my $a =  hex "0xffffffffffffffffffff" ;
+     Hexadecimal number > 0xffffffff non-portable
+   	$a =  hex "0x1ffffffff" ;
+
+__END__
+# util.c
+use warnings 'digit' ;
+my $a = oct "029" ;
+no warnings 'digit' ;
+$a = oct "029" ;
+EXPECT
+Illegal octal digit '9' ignored at - line 3.
+########
+# util.c
+use warnings 'digit' ;
+my $a =  hex "0xv9" ;
+no warnings 'digit' ;
+$a =  hex "0xv9" ;
+EXPECT
+Illegal hexadecimal digit 'v' ignored at - line 3.
+########
+# util.c
+use warnings 'digit' ;
+my $a =  oct "0b9" ;
+no warnings 'digit' ;
+$a =  oct "0b9" ;
+EXPECT
+Illegal binary digit '9' ignored at - line 3.
+########
+# util.c
+use warnings 'overflow' ;
+my $a =  oct "0b11111111111111111111111111111111111111111111111111111111111111111";
+no warnings 'overflow' ;
+$a =  oct "0b11111111111111111111111111111111111111111111111111111111111111111";
+EXPECT
+Integer overflow in binary number at - line 3.
+########
+# util.c
+use warnings 'overflow' ;
+my $a =  hex "0xffffffffffffffffffff" ;
+no warnings 'overflow' ;
+$a =  hex "0xffffffffffffffffffff" ;
+EXPECT
+Integer overflow in hexadecimal number at - line 3.
+########
+# util.c
+use warnings 'overflow' ;
+my $a =  oct "077777777777777777777777777777" ;
+no warnings 'overflow' ;
+$a =  oct "077777777777777777777777777777" ;
+EXPECT
+Integer overflow in octal number at - line 3.
+########
+# util.c
+use warnings 'portable' ;
+my $a =  oct "0b011111111111111111111111111111110" ;
+   $a =  oct "0b011111111111111111111111111111111" ;
+   $a =  oct "0b111111111111111111111111111111111" ;
+no warnings 'portable' ;
+   $a =  oct "0b011111111111111111111111111111110" ;
+   $a =  oct "0b011111111111111111111111111111111" ;
+   $a =  oct "0b111111111111111111111111111111111" ;
+EXPECT
+Binary number > 0b11111111111111111111111111111111 non-portable at - line 5.
+########
+# util.c
+use warnings 'portable' ;
+my $a =  hex "0x0fffffffe" ;
+   $a =  hex "0x0ffffffff" ;
+   $a =  hex "0x1ffffffff" ;
+no warnings 'portable' ;
+   $a =  hex "0x0fffffffe" ;
+   $a =  hex "0x0ffffffff" ;
+   $a =  hex "0x1ffffffff" ;
+EXPECT
+Hexadecimal number > 0xffffffff non-portable at - line 5.
+########
+# util.c
+use warnings 'portable' ;
+my $a =  oct "0037777777776" ;
+   $a =  oct "0037777777777" ;
+   $a =  oct "0047777777777" ;
+no warnings 'portable' ;
+   $a =  oct "0037777777776" ;
+   $a =  oct "0037777777777" ;
+   $a =  oct "0047777777777" ;
+EXPECT
+Octal number > 037777777777 non-portable at - line 5.
+########
+# util.c
+use warnings;
+$x = 1;
+if ($x) {
+    print $y;
+}
+EXPECT
+Name "main::y" used only once: possible typo at - line 5.
+Use of uninitialized value in print at - line 5.
+########
+# util.c
+use warnings;
+$x = 1;
+if ($x) {
+    $x++;
+    print $y;
+}
+EXPECT
+Name "main::y" used only once: possible typo at - line 6.
+Use of uninitialized value in print at - line 6.
+########
+# util.c
+use warnings;
+$x = 0;
+if ($x) {
+    print "1\n";
+} elsif (!$x) {
+    print $y;
+} else {
+    print "0\n";
+}
+EXPECT
+Name "main::y" used only once: possible typo at - line 7.
+Use of uninitialized value in print at - line 7.
+########
+# util.c
+use warnings;
+$x = 0;
+if ($x) {
+    print "1\n";
+} elsif (!$x) {
+    $x++;
+    print $y;
+} else {
+    print "0\n";
+}
+EXPECT
+Name "main::y" used only once: possible typo at - line 8.
+Use of uninitialized value in print at - line 8.
diff --git a/gnu/usr.bin/perl/t/op/64bitint.t b/gnu/usr.bin/perl/t/op/64bitint.t
index 88fbc55c671..e8314fac8a2 100644
--- a/gnu/usr.bin/perl/t/op/64bitint.t
+++ b/gnu/usr.bin/perl/t/op/64bitint.t
@@ -3,7 +3,7 @@
 BEGIN {
 	eval { my $q = pack "q", 0 };
 	if ($@) {
-		print "1..0\n# Skip: no 64-bit types\n";
+		print "1..0 # Skip: no 64-bit types\n";
 		exit(0);
 	}
 	chdir 't' if -d 't';
@@ -14,9 +14,25 @@ BEGIN {
 
 # so that using > 0xfffffff constants and
 # 32+ bit integers don't cause noise
+use warnings;
 no warnings qw(overflow portable);
 
-print "1..55\n";
+print "1..67\n";
+
+# as 6 * 6 = 36, the last digit of 6**n will always be six. Hence the last
+# digit of 16**n will always be six. Hence 16**n - 1 will always end in 5.
+# Assumption is that UVs will always be a multiple of 4 bits long.
+
+my $UV_max = ~0;
+die "UV_max eq '$UV_max', doesn't end in 5; your UV isn't 4n bits long :-(."
+  unless $UV_max =~ /5$/;
+my $UV_max_less3 = $UV_max - 3;
+my $maths_preserves_UVs = $UV_max_less3 =~ /^\d+2$/;   # 5 - 3 is 2.
+if ($maths_preserves_UVs) {
+  print "# This perl's maths preserves all bits of a UV.\n";
+} else {
+  print "# This perl's maths does not preserve all bits of a UV.\n";
+}
 
 my $q = 12345678901;
 my $r = 23456789012;
@@ -294,4 +310,108 @@ $q = 18446744073709551615;
 print "# $q ne\n# 18446744073709551615\nnot " unless "$q" eq "18446744073709551615";
 print "ok 55\n";
 
+# Test that sv_2nv then sv_2iv is the same as sv_2iv direct
+# fails if whatever Atol is defined as can't actually cope with >32 bits.
+my $num = 4294967297;
+my $string = "4294967297";
+{
+  use integer;
+  $num += 0;
+  $string += 0;
+}
+if ($num eq $string) {
+  print "ok 56\n";
+} else {
+  print "not ok 56 # \"$num\" ne \"$string\"\n";
+}
+
+# Test that sv_2nv then sv_2uv is the same as sv_2uv direct
+$num = 4294967297;
+$string = "4294967297";
+$num &= 0;
+$string &= 0;
+if ($num eq $string) {
+  print "ok 57\n";
+} else {
+  print "not ok 57 # \"$num\" ne \"$string\"\n";
+}
+
+$q = "18446744073709551616e0";
+$q += 0;
+print "# \"18446744073709551616e0\" += 0 gives $q\nnot " if "$q" eq "18446744073709551615";
+print "ok 58\n";
+
+# 0xFFFFFFFFFFFFFFFF ==  1 * 3 * 5 * 17 * 257 * 641 * 65537 * 6700417'
+$q = 0xFFFFFFFFFFFFFFFF / 3;
+if ($q == 0x5555555555555555 and ($q != 0x5555555555555556
+                                  or !$maths_preserves_UVs)) {
+  print "ok 59\n";
+} else {
+  print "not ok 59 # 0xFFFFFFFFFFFFFFFF / 3 = $q\n";
+  print "# Should not be floating point\n" if $q =~ tr/e.//;
+}
+
+$q = 0xFFFFFFFFFFFFFFFF % 0x5555555555555555;
+if ($q == 0) {
+  print "ok 60\n";
+} else {
+  print "not ok 60 # 0xFFFFFFFFFFFFFFFF % 0x5555555555555555 => $q\n";
+}
+
+$q = 0xFFFFFFFFFFFFFFFF % 0xFFFFFFFFFFFFFFF0;
+if ($q == 0xF) {
+  print "ok 61\n";
+} else {
+  print "not ok 61 # 0xFFFFFFFFFFFFFFFF % 0xFFFFFFFFFFFFFFF0 => $q\n";
+}
+
+$q = 0x8000000000000000 % 9223372036854775807;
+if ($q == 1) {
+  print "ok 62\n";
+} else {
+  print "not ok 62 # 0x8000000000000000 % 9223372036854775807 => $q\n";
+}
+
+$q = 0x8000000000000000 % -9223372036854775807;
+if ($q == -9223372036854775806) {
+  print "ok 63\n";
+} else {
+  print "not ok 63 # 0x8000000000000000 % -9223372036854775807 => $q\n";
+}
+
+{
+  use integer;
+  $q = hex "0x123456789abcdef0";
+  if ($q == 0x123456789abcdef0 and $q != 0x123456789abcdef1) {
+    print "ok 64\n";
+  } else {
+    printf "not ok 64 # hex \"0x123456789abcdef0\" = $q (%X)\n", $q;
+    print "# Should not be floating point\n" if $q =~ tr/e.//;
+  }
+
+  $q = oct "0x123456789abcdef0";
+  if ($q == 0x123456789abcdef0 and $q != 0x123456789abcdef1) {
+    print "ok 65\n";
+  } else {
+    printf "not ok 65 # oct \"0x123456789abcdef0\" = $q (%X)\n", $q;
+    print "# Should not be floating point\n" if $q =~ tr/e.//;
+  }
+
+  $q = oct "765432176543217654321";
+  if ($q == 0765432176543217654321 and $q != 0765432176543217654322) {
+    print "ok 66\n";
+  } else {
+    printf "not ok 66 # oct \"765432176543217654321\" = $q (%o)\n", $q;
+    print "# Should not be floating point\n" if $q =~ tr/e.//;
+  }
+
+  $q = oct "0b0101010101010101010101010101010101010101010101010101010101010101";
+  if ($q == 0x5555555555555555 and $q != 0x5555555555555556) {
+    print "ok 67\n";
+  } else {
+    printf "not ok 67 # oct \"0b0101010101010101010101010101010101010101010101010101010101010101\" = $q (%b)\n", $q;
+    print "# Should not be floating point\n" if $q =~ tr/e.//;
+  }
+}
+
 # eof
diff --git a/gnu/usr.bin/perl/t/op/alarm.t b/gnu/usr.bin/perl/t/op/alarm.t
new file mode 100644
index 00000000000..8fb92964a3a
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/alarm.t
@@ -0,0 +1,51 @@
+#!./perl 
+
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+BEGIN {
+    use Config;
+    if( !$Config{d_alarm} ) {
+        skip_all("alarm() not implemented on this platform");
+    }
+}
+
+plan tests => 4;
+my $Perl = which_perl();
+
+my $start_time = time;
+eval {
+    local $SIG{ALRM} = sub { die "ALARM!\n" };
+    alarm 3;
+
+    # perlfunc recommends against using sleep in combination with alarm.
+    1 while (time - $start_time < 6);
+};
+alarm 0;
+my $diff = time - $start_time;
+
+# alarm time might be one second less than you said.
+is( $@, "ALARM!\n",             'alarm w/$SIG{ALRM} vs inf loop' );
+ok( abs($diff - 3) <= 1,   "   right time" );
+
+
+my $start_time = time;
+eval {
+    local $SIG{ALRM} = sub { die "ALARM!\n" };
+    alarm 3;
+    system(qq{$Perl -e "sleep 6"});
+};
+alarm 0;
+$diff = time - $start_time;
+
+# alarm time might be one second less than you said.
+is( $@, "ALARM!\n",             'alarm w/$SIG{ALRM} vs system()' );
+
+{
+    local $TODO = "Why does system() block alarm() on $^O?"
+		if $^O eq 'VMS' || $^O eq'MacOS' || $^O eq 'dos';
+    ok( abs($diff - 3) <= 1,   "   right time (waited $diff secs for 3-sec alarm)" );
+}
diff --git a/gnu/usr.bin/perl/t/op/anonsub.t b/gnu/usr.bin/perl/t/op/anonsub.t
index 17889d9d2f9..8eca75b8119 100644
--- a/gnu/usr.bin/perl/t/op/anonsub.t
+++ b/gnu/usr.bin/perl/t/op/anonsub.t
@@ -4,6 +4,8 @@ chdir 't' if -d 't';
 @INC = '../lib';
 $Is_VMS = $^O eq 'VMS';
 $Is_MSWin32 = $^O eq 'MSWin32';
+$Is_MacOS = $^O eq 'MacOS';
+$Is_NetWare = $^O eq 'NetWare';
 $ENV{PERL5LIB} = "../lib" unless $Is_VMS;
 
 $|=1;
@@ -24,12 +26,16 @@ for (@prgs){
     my($prog,$expected) = split(/\nEXPECT\n/, $_);
     open TEST, ">$tmpfile";
     print TEST "$prog\n";
-    close TEST;
+    close TEST or die "Could not close: $!";
     my $results = $Is_VMS ?
-                  `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
-		      $Is_MSWin32 ?  
-			  `.\\perl -I../lib $switch $tmpfile 2>&1` :
-			      `./perl $switch $tmpfile 2>&1`;
+		`MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
+		  $Is_MSWin32 ?
+		    `.\\perl -I../lib $switch $tmpfile 2>&1` :
+		      $Is_MacOS ?  
+			`$^X -I::lib $switch $tmpfile` :
+			    $Is_NetWare ?
+				`perl -I../lib $switch $tmpfile 2>&1` :
+				    `./perl $switch $tmpfile 2>&1`;
     my $status = $?;
     $results =~ s/\n+$//;
     # allow expected output to be written as if $prog is on STDIN
@@ -91,3 +97,8 @@ sub X {
 X();
 EXPECT
 ok 1
+########
+package;
+print sub { return "ok 1\n" } -> ();
+EXPECT
+ok 1
diff --git a/gnu/usr.bin/perl/t/op/attrs.t b/gnu/usr.bin/perl/t/op/attrs.t
index 27020048816..1ed92a1a8d2 100644
--- a/gnu/usr.bin/perl/t/op/attrs.t
+++ b/gnu/usr.bin/perl/t/op/attrs.t
@@ -19,6 +19,7 @@ print "1..".NTESTS."\n";
 $SIG{__WARN__} = sub { die @_ };
 
 sub mytest {
+    my $bad = '';
     if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) {
 	if ($@) {
 	    my $x = $@;
@@ -35,15 +36,15 @@ sub mytest {
 	    print "# Expected success\n";
 	}
 	$failed = 1;
-	print "not ";
+	$bad = 'not ';
     }
     elsif (@_ == 3 && $_[1] ne $_[2]) {
 	print "# Got: $_[1]\n";
 	print "# Expected: $_[2]\n";
 	$failed = 1;
-	print "not ";
+	$bad = 'not ';
     }
-    print "ok ",++$test,"\n";
+    print $bad."ok ".++$test."\n";
 }
 
 eval 'sub t1 ($) : locked { $_[0]++ }';
@@ -142,15 +143,20 @@ eval 'my A $x : plugh plover;';
 mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /;
 BEGIN {++$ntests}
 
+eval 'package Cat; my Cat @socks;';
+mytest qr/^Can't declare class for non-scalar \@socks in "my"/;
+BEGIN {++$ntests}
+
 sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" }
 sub X::foo { 1 }
 *Y::bar = \&X::foo;
 *Y::bar = \&X::foo;	# second time for -w
-eval 'package Z; sub Y::bar : locked';
+eval 'package Z; sub Y::bar : foo';
 mytest qr/^X at /;
 BEGIN {++$ntests}
 
-my @attrs = eval 'attributes::get \&Y::bar';
+eval 'package Z; sub Y::baz : locked {}';
+my @attrs = eval 'attributes::get \&Y::baz';
 mytest '', "@attrs", "locked";
 BEGIN {++$ntests}
 
@@ -168,6 +174,45 @@ BEGIN {++$ntests}
 mytest '', "@attrs", "locked method Z";
 BEGIN {++$ntests}
 
+# Test ability to modify existing sub's (or XSUB's) attributes.
+eval 'package A; sub X { $_[0] } sub X : lvalue';
+@attrs = eval 'attributes::get \&A::X';
+mytest '', "@attrs", "lvalue";
+BEGIN {++$ntests}
+
+# Above not with just 'pure' built-in attributes.
+sub Z::MODIFY_CODE_ATTRIBUTES { (); }
+eval 'package Z; sub L { $_[0] } sub L : Z lvalue';
+@attrs = eval 'attributes::get \&Z::L';
+mytest '', "@attrs", "lvalue Z";
+BEGIN {++$ntests}
+
+
+# Begin testing attributes that tie
+
+{
+    package Ttie;
+    sub DESTROY {}
+    sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; }
+    sub FETCH { ${$_[0]} }
+    sub STORE {
+	#print "# In Ttie::STORE\n";
+	::mytest '';
+	${$_[0]} = $_[1]*2;
+    }
+    package Tloop;
+    sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); }
+}
+
+eval '
+    package Tloop;
+    for my $i (0..2) {
+	my $x : TieLoop = $i;
+	$x != $i*2 and ::mytest "", $x, $i*2;
+    }
+';
+mytest;
+BEGIN {$ntests += 4}
 
 # Other tests should be added above this line
 
diff --git a/gnu/usr.bin/perl/t/op/avhv.t b/gnu/usr.bin/perl/t/op/avhv.t
index 5b91fd21474..1ee1da72d64 100644
--- a/gnu/usr.bin/perl/t/op/avhv.t
+++ b/gnu/usr.bin/perl/t/op/avhv.t
@@ -17,7 +17,7 @@ sub STORESIZE { $#{$_[0]} = $_[1]+1 }
 
 package main;
 
-print "1..28\n";
+print "1..29\n";
 
 $sch = {
     'abc' => 1,
@@ -176,3 +176,9 @@ print "ok 27\n";
 (@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
 print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6;
 print "ok 28\n";
+
+# Check hash slices (BUG ID 20010423.002)
+$avhv = [{foo=>1, bar=>2}];
+@$avhv{"foo", "bar"} = (42, 53);
+print "not " unless $avhv->{foo} == 42 && $avhv->{bar} == 53;
+print "ok 29\n";
diff --git a/gnu/usr.bin/perl/t/op/bless.t b/gnu/usr.bin/perl/t/op/bless.t
new file mode 100644
index 00000000000..3aaceb8ce73
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/bless.t
@@ -0,0 +1,127 @@
+#!./perl
+
+print "1..31\n";
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+sub expected {
+    my($object, $package, $type) = @_;
+    return "" if (
+	ref($object) eq $package
+	&& "$object" =~ /^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/
+	&& $1 eq $type
+	# in 64-bit platforms hex warns for 32+ -bit values
+	&& do { no warnings 'portable'; hex($2) == $object }
+    );
+    print "# $object $package $type\n";
+    return "not ";
+}
+
+# test blessing simple types
+
+$a1 = bless {}, "A";
+print expected($a1, "A", "HASH"), "ok 1\n";
+$b1 = bless [], "B";
+print expected($b1, "B", "ARRAY"), "ok 2\n";
+$c1 = bless \(map "$_", "test"), "C";
+print expected($c1, "C", "SCALAR"), "ok 3\n";
+our $test = "foo"; $d1 = bless \*test, "D";
+print expected($d1, "D", "GLOB"), "ok 4\n";
+$e1 = bless sub { 1 }, "E";
+print expected($e1, "E", "CODE"), "ok 5\n";
+$f1 = bless \[], "F";
+print expected($f1, "F", "REF"), "ok 6\n";
+$g1 = bless \substr("test", 1, 2), "G";
+print expected($g1, "G", "LVALUE"), "ok 7\n";
+
+# blessing ref to object doesn't modify object
+
+print expected(bless(\$a1, "F"), "F", "REF"), "ok 8\n";
+print expected($a1, "A", "HASH"), "ok 9\n";
+
+# reblessing does modify object
+
+bless $a1, "A2";
+print expected($a1, "A2", "HASH"), "ok 10\n";
+
+# local and my
+{
+    local $a1 = bless $a1, "A3";	# should rebless outer $a1
+    local $b1 = bless [], "B3";
+    my $c1 = bless $c1, "C3";		# should rebless outer $c1
+    our $test2 = ""; my $d1 = bless \*test2, "D3";
+    print expected($a1, "A3", "HASH"), "ok 11\n";
+    print expected($b1, "B3", "ARRAY"), "ok 12\n";
+    print expected($c1, "C3", "SCALAR"), "ok 13\n";
+    print expected($d1, "D3", "GLOB"), "ok 14\n";
+}
+print expected($a1, "A3", "HASH"), "ok 15\n";
+print expected($b1, "B", "ARRAY"), "ok 16\n";
+print expected($c1, "C3", "SCALAR"), "ok 17\n";
+print expected($d1, "D", "GLOB"), "ok 18\n";
+
+# class is magic
+"E" =~ /(.)/;
+print expected(bless({}, $1), "E", "HASH"), "ok 19\n";
+{
+    local $! = 1;
+    my $string = "$!";
+    $! = 2;	# attempt to avoid cached string
+    $! = 1;
+    print expected(bless({}, $!), $string, "HASH"), "ok 20\n";
+
+# ref is ref to magic
+    {
+	{
+	    package F;
+	    sub test { ${$_[0]} eq $string or print "not " }
+	}
+	$! = 2;
+	$f1 = bless \$!, "F";
+	$! = 1;
+	$f1->test;
+	print "ok 21\n";
+    }
+}
+
+# ref is magic
+### example of magic variable that is a reference??
+
+# no class, or empty string (with a warning), or undef (with two)
+print expected(bless([]), 'main', "ARRAY"), "ok 22\n";
+{
+    local $SIG{__WARN__} = sub { push @w, join '', @_ };
+    use warnings;
+
+    $m = bless [];
+    print expected($m, 'main', "ARRAY"), "ok 23\n";
+    print @w ? "not ok 24\t# @w\n" : "ok 24\n";
+
+    @w = ();
+    $m = bless [], '';
+    print expected($m, 'main', "ARRAY"), "ok 25\n";
+    print @w != 1 ? "not ok 26\t# @w\n" : "ok 26\n";
+
+    @w = ();
+    $m = bless [], undef;
+    print expected($m, 'main', "ARRAY"), "ok 27\n";
+    print @w != 2 ? "not ok 28\t# @w\n" : "ok 28\n";
+}
+
+# class is a ref
+$a1 = bless {}, "A4";
+$b1 = eval { bless {}, $a1 };
+print $@ ? "ok 29\n" : "not ok 29\t# $b1\n";
+
+# class is an overloaded ref
+{
+    package H4;
+    use overload '""' => sub { "C4" };
+}
+$h1 = bless {}, "H4";
+$c4 = eval { bless \$test, $h1 };
+print expected($c4, 'C4', "SCALAR"), "ok 30\n";
+print $@ ? "not ok 31\t# $@" : "ok 31\n";
diff --git a/gnu/usr.bin/perl/t/op/caller.t b/gnu/usr.bin/perl/t/op/caller.t
new file mode 100644
index 00000000000..751a161de2a
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/caller.t
@@ -0,0 +1,65 @@
+#!./perl
+# Tests for caller()
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+plan( tests => 20 );
+
+my @c;
+
+print "# Tests with caller(0)\n";
+
+@c = caller(0);
+ok( (!@c), "caller(0) in main program" );
+
+eval { @c = caller(0) };
+is( $c[3], "(eval)", "subroutine name in an eval {}" );
+ok( !$c[4], "hasargs false in an eval {}" );
+
+eval q{ @c = (Caller(0))[3] };
+is( $c[3], "(eval)", "subroutine name in an eval ''" );
+ok( !$c[4], "hasargs false in an eval ''" );
+
+sub { @c = caller(0) } -> ();
+is( $c[3], "main::__ANON__", "anonymous subroutine name" );
+ok( $c[4], "hasargs true with anon sub" );
+
+# Bug 20020517.003, used to dump core
+sub foo { @c = caller(0) }
+my $fooref = delete $::{foo};
+$fooref -> ();
+is( $c[3], "(unknown)", "unknown subroutine name" );
+ok( $c[4], "hasargs true with unknown sub" );
+
+print "# Tests with caller(1)\n";
+
+sub f { @c = caller(1) }
+
+sub callf { f(); }
+callf();
+is( $c[3], "main::callf", "subroutine name" );
+ok( $c[4], "hasargs true with callf()" );
+&callf;
+ok( !$c[4], "hasargs false with &callf" );
+
+eval { f() };
+is( $c[3], "(eval)", "subroutine name in an eval {}" );
+ok( !$c[4], "hasargs false in an eval {}" );
+
+eval q{ f() };
+is( $c[3], "(eval)", "subroutine name in an eval ''" );
+ok( !$c[4], "hasargs false in an eval ''" );
+
+sub { f() } -> ();
+is( $c[3], "main::__ANON__", "anonymous subroutine name" );
+ok( $c[4], "hasargs true with anon sub" );
+
+sub foo2 { f() }
+my $fooref2 = delete $::{foo2};
+$fooref2 -> ();
+is( $c[3], "(unknown)", "unknown subroutine name" );
+ok( $c[4], "hasargs true with unknown sub" );
diff --git a/gnu/usr.bin/perl/t/op/chdir.t b/gnu/usr.bin/perl/t/op/chdir.t
new file mode 100644
index 00000000000..2932b922ea6
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/chdir.t
@@ -0,0 +1,134 @@
+#!./perl -w
+
+BEGIN {
+    # We're not going to chdir() into 't' because we don't know if
+    # chdir() works!  Instead, we'll hedge our bets and put both
+    # possibilities into @INC.
+    @INC = qw(t . lib ../lib);
+}
+
+use Config;
+require "test.pl";
+plan(tests => 31);
+
+my $IsVMS   = $^O eq 'VMS';
+my $IsMacOS = $^O eq 'MacOS';
+
+# Might be a little early in the testing process to start using these,
+# but I can't think of a way to write this test without them.
+use File::Spec::Functions qw(:DEFAULT splitdir rel2abs splitpath);
+
+# Can't use Cwd::abs_path() because it has different ideas about
+# path separators than File::Spec.
+sub abs_path {
+    $IsVMS ? uc(rel2abs(curdir)) : rel2abs(curdir);
+}
+
+my $Cwd = abs_path;
+
+# Let's get to a known position
+SKIP: {
+    my ($vol,$dir) = splitpath(abs_path,1);
+    my $test_dir = $IsVMS ? 'T' : 't';
+    skip("Already in t/", 2) if (splitdir($dir))[-1] eq $test_dir;
+
+    ok( chdir($test_dir),     'chdir($test_dir)');
+    is( abs_path, catdir($Cwd, $test_dir),    '  abs_path() agrees' );
+}
+
+$Cwd = abs_path;
+
+# The environment variables chdir() pays attention to.
+my @magic_envs = qw(HOME LOGDIR SYS$LOGIN);
+
+sub check_env {
+    my($key) = @_;
+
+    # Make sure $ENV{'SYS$LOGIN'} is only honored on VMS.
+    if( $key eq 'SYS$LOGIN' && !$IsVMS && !$IsMacOS ) {
+        ok( !chdir(),         "chdir() on $^O ignores only \$ENV{$key} set" );
+        is( abs_path, $Cwd,   '  abs_path() did not change' );
+        pass( "  no need to test SYS\$LOGIN on $^O" ) for 1..7;
+    }
+    else {
+        ok( chdir(),              "chdir() w/ only \$ENV{$key} set" );
+        is( abs_path, $ENV{$key}, '  abs_path() agrees' );
+        chdir($Cwd);
+        is( abs_path, $Cwd,       '  and back again' );
+
+        my $warning = '';
+        local $SIG{__WARN__} = sub { $warning .= join '', @_ };
+
+
+        # Check the deprecated chdir(undef) feature.
+#line 64
+        ok( chdir(undef),           "chdir(undef) w/ only \$ENV{$key} set" );
+        is( abs_path, $ENV{$key},   '  abs_path() agrees' );
+        is( $warning,  <<WARNING,   '  got uninit & deprecation warning' );
+Use of uninitialized value in chdir at $0 line 64.
+Use of chdir('') or chdir(undef) as chdir() is deprecated at $0 line 64.
+WARNING
+
+        chdir($Cwd);
+
+        # Ditto chdir('').
+        $warning = '';
+#line 76
+        ok( chdir(''),              "chdir('') w/ only \$ENV{$key} set" );
+        is( abs_path, $ENV{$key},   '  abs_path() agrees' );
+        is( $warning,  <<WARNING,   '  got deprecation warning' );
+Use of chdir('') or chdir(undef) as chdir() is deprecated at $0 line 76.
+WARNING
+
+        chdir($Cwd);
+    }
+}
+
+my %Saved_Env = ();
+sub clean_env {
+    foreach my $env (@magic_envs) {
+        $Saved_Env{$env} = $ENV{$env};
+
+        # Can't actually delete SYS$ stuff on VMS.
+        next if $IsVMS && $env eq 'SYS$LOGIN';
+        next if $IsVMS && $env eq 'HOME' && !$Config{'d_setenv'};
+
+        unless ($IsMacOS) { # ENV on MacOS is "special" :-)
+            # On VMS, %ENV is many layered.
+            delete $ENV{$env} while exists $ENV{$env};
+        }
+    }
+
+    # The following means we won't really be testing for non-existence,
+    # but in Perl we can only delete from the process table, not the job 
+    # table.
+    $ENV{'SYS$LOGIN'} = '' if $IsVMS;
+}
+
+END {
+    no warnings 'uninitialized';
+
+    # Restore the environment for VMS (and doesn't hurt for anyone else)
+    @ENV{@magic_envs} = @Saved_Env{@magic_envs};
+}
+
+
+foreach my $key (@magic_envs) {
+    # We're going to be using undefs a lot here.
+    no warnings 'uninitialized';
+
+    clean_env;
+    $ENV{$key} = catdir $Cwd, ($IsVMS ? 'OP' : 'op');
+
+    check_env($key);
+}
+
+{
+    clean_env;
+    if (($IsVMS || $IsMacOS) && !$Config{'d_setenv'}) {
+        pass("Can't reset HOME, so chdir() test meaningless");
+    } else {
+        ok( !chdir(),                   'chdir() w/o any ENV set' );
+    }
+    is( abs_path, $Cwd,             '  abs_path() agrees' );
+}
diff --git a/gnu/usr.bin/perl/t/op/concat.t b/gnu/usr.bin/perl/t/op/concat.t
index 76074e0f28f..4813690d6be 100644
--- a/gnu/usr.bin/perl/t/op/concat.t
+++ b/gnu/usr.bin/perl/t/op/concat.t
@@ -5,22 +5,28 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..11\n";
+# This ok() function is specially written to avoid any concatenation.
+my $test = 1;
+sub ok {
+    my($ok, $name) = @_;
 
-($a, $b, $c) = qw(foo bar);
+    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name;
 
-print "not " unless "$a" eq "foo";
-print "ok 1\n";
+    printf "# Failed test at line %d\n", (caller)[2] unless $ok;
 
-print "not " unless "$a$b" eq "foobar";
-print "ok 2\n";
+    $test++;
+    return $ok;
+}
 
-print "not " unless "$c$a$c" eq "foo";
-print "ok 3\n";
+print "1..12\n";
 
-# Okay, so that wasn't very challenging.  Let's go Unicode.
+($a, $b, $c) = qw(foo bar);
+
+ok("$a"     eq "foo",    "verifying assign");
+ok("$a$b"   eq "foobar", "basic concatenation");
+ok("$c$a$c" eq "foo",    "concatenate undef, fore and aft");
 
-my $test = 4;
+# Okay, so that wasn't very challenging.  Let's go Unicode.
 
 {
     # bug id 20000819.004 
@@ -28,29 +34,20 @@ my $test = 4;
     $_ = $dx = "\x{10f2}";
     s/($dx)/$dx$1/;
     {
-	use bytes;
-	print "not " unless $_ eq "$dx$dx";
-	print "ok $test\n";
-	$test++;
+        ok($_ eq  "$dx$dx","bug id 20000819.004, back");
     }
 
     $_ = $dx = "\x{10f2}";
     s/($dx)/$1$dx/;
     {
-	use bytes;
-	print "not " unless $_ eq "$dx$dx";
-	print "ok $test\n";
-	$test++;
+        ok($_ eq  "$dx$dx","bug id 20000819.004, front");
     }
 
     $dx = "\x{10f2}";
     $_  = "\x{10f2}\x{10f2}";
     s/($dx)($dx)/$1$2/;
     {
-	use bytes;
-	print "not " unless $_ eq "$dx$dx";
-	print "ok $test\n";
-	$test++;
+        ok($_ eq  "$dx$dx","bug id 20000819.004, front and back");
     }
 }
 
@@ -60,9 +57,9 @@ my $test = 4;
 
     my $a;
     $a .= "\x{1ff}";
-    print "not " unless $a eq "\x{1ff}";
-    print "ok $test\n";
-    $test++;
+    ok($a eq  "\x{1ff}", "bug id 20000901.092, undef left");
+    $a .= undef;
+    ok($a eq  "\x{1ff}", "bug id 20000901.092, undef right");
 }
 
 {
@@ -72,29 +69,21 @@ my $test = 4;
 
     # Without the fix this 5.7.0 would croak:
     # Modification of a read-only value attempted at ...
-    "$2\x{1234}";
-
-    print "ok $test\n";
-    $test++;
+    eval {"$2\x{1234}"};
+    ok(!$@, "bug id 20001020.006, left");
 
     # For symmetry with the above.
-    "\x{1234}$2";
-
-    print "ok $test\n";
-    $test++;
+    eval {"\x{1234}$2"};
+    ok(!$@, "bug id 20001020.006, right");
 
     *pi = \undef;
     # This bug existed earlier than the $2 bug, but is fixed with the same
     # patch. Without the fix this 5.7.0 would also croak:
     # Modification of a read-only value attempted at ...
-    "$pi\x{1234}";
-
-    print "ok $test\n";
-    $test++;
+    eval{"$pi\x{1234}"};
+    ok(!$@, "bug id 20001020.006, constant left");
 
     # For symmetry with the above.
-    "\x{1234}$pi";
-
-    print "ok $test\n";
-    $test++;
+    eval{"\x{1234}$pi"};
+    ok(!$@, "bug id 20001020.006, constant right");
 }
diff --git a/gnu/usr.bin/perl/t/op/crypt.t b/gnu/usr.bin/perl/t/op/crypt.t
new file mode 100644
index 00000000000..27c878f1bd5
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/crypt.t
@@ -0,0 +1,46 @@
+#!./perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(. ../lib);
+}
+
+BEGIN {
+    use Config;
+
+    require "test.pl";
+
+    if( !$Config{d_crypt} ) {
+        skip_all("crypt unimplemented");
+    }
+    else {
+        plan(tests => 4);
+    }
+}
+
+# Can't assume too much about the string returned by crypt(),
+# and about how many bytes of the encrypted (really, hashed)
+# string matter.
+#
+# HISTORICALLY the results started with the first two bytes of the salt,
+# followed by 11 bytes from the set [./0-9A-Za-z], and only the first
+# eight characters mattered, but those are probably no more safe
+# bets, given alternative encryption/hashing schemes like MD5,
+# C2 (or higher) security schemes, and non-UNIX platforms.
+
+SKIP: {
+	skip ("VOS crypt ignores salt.", 1) if ($^O eq 'vos');
+	ok(substr(crypt("ab", "cd"), 2) ne substr(crypt("ab", "ce"), 2), "salt makes a difference");
+}
+
+$a = "a\xFF\x{100}";
+
+eval {$b = crypt($a, "cd")};
+like($@, qr/Wide character in crypt/, "wide characters ungood");
+
+chop $a; # throw away the wide character
+
+eval {$b = crypt($a, "cd")};
+is($@, '',                   "downgrade to eight bit characters");
+is($b, crypt("a\xFF", "cd"), "downgrade results agree");
+
diff --git a/gnu/usr.bin/perl/t/op/defins.t b/gnu/usr.bin/perl/t/op/defins.t
index 33c74ea28e8..06d48b601bc 100644
--- a/gnu/usr.bin/perl/t/op/defins.t
+++ b/gnu/usr.bin/perl/t/op/defins.t
@@ -12,16 +12,17 @@ BEGIN {
 }
 
 $wanted_filename = $^O eq 'VMS' ? '0.' : '0';
+$saved_filename = $^O eq 'MacOS' ? ':0' : './0';
     
 print "not " if $warns;
 print "ok 1\n";
 
-open(FILE,">./0");
+open(FILE,">$saved_filename");
 print FILE "1\n";
 print FILE "0";
 close(FILE);
 
-open(FILE,"<./0");
+open(FILE,"<$saved_filename");
 my $seen = 0;
 my $dummy;
 while (my $name = <FILE>)
@@ -63,7 +64,7 @@ print "not " unless $seen;
 print "ok 5\n";
 close FILE;
 
-opendir(DIR,'.');
+opendir(DIR,($^O eq 'MacOS' ? ':' : '.'));
 $seen = 0;
 while (my $name = readdir(DIR))
  {
@@ -116,7 +117,7 @@ while ($where{$seen} = glob('*'))
 print "not " unless $seen;
 print "ok 11\n";
 
-unlink("./0");
+unlink($saved_filename);
 
 my %hash = (0 => 1, 1 => 2);
 
diff --git a/gnu/usr.bin/perl/t/op/die_exit.t b/gnu/usr.bin/perl/t/op/die_exit.t
index a389946fe37..fedef945e1e 100644
--- a/gnu/usr.bin/perl/t/op/die_exit.t
+++ b/gnu/usr.bin/perl/t/op/die_exit.t
@@ -15,7 +15,7 @@ if ($^O eq 'mpeix') {
     exit 0;
 }
 
-my $perl = -e '../perl' ? '../perl' : -e './perl' ? './perl' : 'perl';
+$| = 1;
 
 use strict;
 
@@ -44,16 +44,29 @@ my $max = keys %tests;
 
 print "1..$max\n";
 
+# Dump any error messages from the dying processes off to a temp file.
+open(STDERR, ">die_exit.err") or die "Can't open temp error file:  $!";
+
 foreach my $test (1 .. $max) {
     my($bang, $query, $code) = @{$tests{$test}};
     $code ||= 'die;';
-    my $exit =
-	($^O eq 'MSWin32'
-	 ? system qq($perl -e "\$! = $bang; \$? = $query; $code" 2> nul)
-	 : system qq($perl -e '\$! = $bang; \$? = $query; $code' 2> /dev/null));
+    if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
+        system(qq{$^X -e "\$! = $bang; \$? = $query; $code"});
+    }
+    else {
+        system(qq{$^X -e '\$! = $bang; \$? = $query; $code'});
+    }
+    my $exit = $?;
+
+    # VMS exit code 44 (SS$_ABORT) is returned if a program dies.  We only get
+    # the severity bits, which boils down to 4.  See L<perlvms/$?>.
+    $bang = 4 if $^O eq 'VMS';
 
     printf "# 0x%04x  0x%04x  0x%04x\n", $exit, $bang, $query;
     print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8);
     print "ok $test\n";
 }
     
+close STDERR;
+END { 1 while unlink 'die_exit.err' }
+
diff --git a/gnu/usr.bin/perl/t/op/filetest.t b/gnu/usr.bin/perl/t/op/filetest.t
index f757c79c05f..fcded7ad037 100644
--- a/gnu/usr.bin/perl/t/op/filetest.t
+++ b/gnu/usr.bin/perl/t/op/filetest.t
@@ -37,6 +37,9 @@ print "# oldeuid = $oldeuid, euid = $>\n";
 
 if (!$Config{d_seteuid}) {
     print "ok 6 #skipped, no seteuid\n";
+} 
+elsif ($Config{config_args} =~/Dmksymlinks/) {
+    print "ok 6 #skipped, we cannot chmod symlinks\n";
 }
 elsif ($bad_chmod) {
     print "#[$@]\nok 6 #skipped\n";
diff --git a/gnu/usr.bin/perl/t/op/gmagic.t b/gnu/usr.bin/perl/t/op/gmagic.t
new file mode 100644
index 00000000000..ab6d2ee3e65
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/gmagic.t
@@ -0,0 +1,83 @@
+#!./perl -w
+
+BEGIN {
+    $| = 1;
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+print "1..18\n";
+
+my $t = 1;
+tie my $c => 'Tie::Monitor';
+
+sub ok {
+    my($ok, $got, $exp, $rexp, $wexp) = @_;
+    my($rgot, $wgot) = (tied $c)->init(0);
+    print $ok ? "ok $t\n" : "# expected $exp, got $got\nnot ok $t\n";
+    ++$t;
+    if ($rexp == $rgot && $wexp == $wgot) {
+	print "ok $t\n";
+    } else {
+	print "# read $rgot expecting $rexp\n" if $rgot != $rexp;
+	print "# wrote $wgot expecting $wexp\n" if $wgot != $wexp;
+	print "not ok $t\n";
+    }
+    ++$t;
+}
+
+sub ok_undef { ok(!defined($_[0]), shift, "undef", @_) }
+sub ok_numeric { ok($_[0] == $_[1], @_) }
+sub ok_string { ok($_[0] eq $_[1], @_) }
+
+my($r, $s);
+# the thing itself
+ok_numeric($r = $c + 0, 0, 1, 0);
+ok_string($r = "$c", '0', 1, 0);
+
+# concat
+ok_string($c . 'x', '0x', 1, 0);
+ok_string('x' . $c, 'x0', 1, 0);
+$s = $c . $c;
+ok_string($s, '00', 2, 0);
+$r = 'x';
+$s = $c = $r . 'y';
+ok_string($s, 'xy', 1, 1);
+$s = $c = $c . 'x';
+ok_string($s, '0x', 2, 1);
+$s = $c = 'x' . $c;
+ok_string($s, 'x0', 2, 1);
+$s = $c = $c . $c;
+ok_string($s, '00', 3, 1);
+
+# adapted from Tie::Counter by Abigail
+package Tie::Monitor;
+
+sub TIESCALAR {
+    my($class, $value) = @_;
+    bless {
+	read => 0,
+	write => 0,
+	values => [ 0 ],
+    };
+}
+
+sub FETCH {
+    my $self = shift;
+    ++$self->{read};
+    $self->{values}[$#{ $self->{values} }];
+}
+
+sub STORE {
+    my($self, $value) = @_;
+    ++$self->{write};
+    push @{ $self->{values} }, $value;
+}
+
+sub init {
+    my $self = shift;
+    my @results = ($self->{read}, $self->{write});
+    $self->{read} = $self->{write} = 0;
+    $self->{values} = [ 0 ];
+    @results;
+}
diff --git a/gnu/usr.bin/perl/t/op/grent.t b/gnu/usr.bin/perl/t/op/grent.t
index 211dc911bba..3611c1b890e 100644
--- a/gnu/usr.bin/perl/t/op/grent.t
+++ b/gnu/usr.bin/perl/t/op/grent.t
@@ -3,60 +3,78 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
-    eval {my @n = getgrgid 0};
-    if ($@ && $@ =~ /(The \w+ function is unimplemented)/) {
-	print "1..0 # Skip: $1\n";
-	exit 0;
-    }
-    eval { require Config; import Config; };
-    my $reason;
-    if ($Config{'i_grp'} ne 'define') {
+    require './test.pl';
+}
+
+eval {my @n = getgrgid 0};
+if ($@ =~ /(The \w+ function is unimplemented)/) {
+    skip_all "getgrgid unimplemented";
+}
+
+eval { require Config; import Config; };
+my $reason;
+if ($Config{'i_grp'} ne 'define') {
 	$reason = '$Config{i_grp} not defined';
-    }
-    elsif (not -f "/etc/group" ) { # Play safe.
+}
+elsif (not -f "/etc/group" ) { # Play safe.
 	$reason = 'no /etc/group file';
-    }
+}
 
-    if (not defined $where) {	# Try NIS.
-	foreach my $ypcat (qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat)) {
-	    if (-x $ypcat &&
-		open(GR, "$ypcat group 2>/dev/null |") &&
-		defined(<GR>)) {
-		$where = "NIS group";
-		undef $reason;
-		last;
-	    }
-	}
+if (not defined $where) {	# Try NIS.
+    foreach my $ypcat (qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat)) {
+        if (-x $ypcat &&
+            open(GR, "$ypcat group 2>/dev/null |") &&
+            defined(<GR>)) 
+        {
+            print "# `ypcat group` worked\n";
+
+            # Check to make sure we're really using NIS.
+            if( open(NSSW, "/etc/nsswitch.conf" ) ) {
+                my($group) = grep /^\s*group:/, <NSSW>;
+
+                # If there's no group line, assume it default to compat.
+                if( !$group || $group !~ /(nis|compat)/ ) {
+                    print "# Doesn't look like you're using NIS in ".
+                          "/etc/nsswitch.conf\n";
+                    last;
+                }
+            }
+            $where = "NIS group - $ypcat";
+            undef $reason;
+            last;
+        }
     }
+}
 
-    if (not defined $where) {	# Try NetInfo.
-	foreach my $nidump (qw(/usr/bin/nidump)) {
-	    if (-x $nidump &&
-		open(GR, "$nidump group . 2>/dev/null |") &&
-		defined(<GR>)) {
-		$where = "NetInfo group";
-		undef $reason;
-		last;
-	    }
-	}
+if (not defined $where) {	# Try NetInfo.
+    foreach my $nidump (qw(/usr/bin/nidump)) {
+        if (-x $nidump &&
+            open(GR, "$nidump group . 2>/dev/null |") &&
+            defined(<GR>)) 
+        {
+            $where = "NetInfo group - $nidump";
+            undef $reason;
+            last;
+        }
     }
+}
 
-    if (not defined $where) {	# Try local.
-	my $GR = "/etc/group";
-	if (-f $GR && open(GR, $GR) && defined(<GR>)) {
-	    undef $reason;
-	    $where = $GR;
-	}
-    }
-    if ($reason) {
-	print "1..0 # Skip: $reason\n";
-	exit 0;
+if (not defined $where) {	# Try local.
+    my $GR = "/etc/group";
+    if (-f $GR && open(GR, $GR) && defined(<GR>)) {
+        undef $reason;
+        $where = "local $GR";
     }
 }
 
+if ($reason) {
+    skip_all $reason;
+}
+
+
 # By now the GR filehandle should be open and full of juicy group entries.
 
-print "1..2\n";
+plan tests => 3;
 
 # Go through at most this many groups.
 # (note that the first entry has been read away by now)
@@ -67,7 +85,10 @@ my $tst = 1;
 my %perfect;
 my %seen;
 
-setgrent();
+print "# where $where\n";
+
+ok( setgrent(), 'setgrent' ) || print "# $!\n";
+
 while (<GR>) {
     chomp;
     # LIMIT -1 so that groups with no users don't fall off
@@ -115,7 +136,9 @@ while (<GR>) {
 
 endgrent();
 
-if (keys %perfect == 0) {
+print "# max = $max, n = $n, perfect = ", scalar keys %perfect, "\n";
+
+if (keys %perfect == 0 && $n) {
     $max++;
     print <<EOEX;
 #
@@ -131,14 +154,12 @@ if (keys %perfect == 0) {
 # matches at all, it suspects something is wrong.
 # 
 EOEX
-    print "not ";
-    $not = 1;
+
+    fail();
+    print "#\t (not necessarily serious: run t/op/grent.t by itself)\n";
 } else {
-    $not = 0;
+    pass();
 }
-print "ok ", $tst++;
-print "\t# (not necessarily serious: run t/op/grent.t by itself)" if $not;
-print "\n";
 
 # Test both the scalar and list contexts.
 
@@ -162,7 +183,6 @@ for (1..$max) {
 }
 endgrent();
 
-print "not " unless "@gr1" eq "@gr2";
-print "ok ", $tst++, "\n";
+is("@gr1", "@gr2");
 
 close(GR);
diff --git a/gnu/usr.bin/perl/t/op/hashassign.t b/gnu/usr.bin/perl/t/op/hashassign.t
new file mode 100644
index 00000000000..a1c66c38dc6
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/hashassign.t
@@ -0,0 +1,275 @@
+#!./perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+# use strict;
+
+plan tests => 206;
+
+my @comma = ("key", "value");
+
+# The peephole optimiser already knows that it should convert the string in
+# $foo{string} into a shared hash key scalar. It might be worth making the
+# tokeniser build the LHS of => as a shared hash key scalar too.
+# And so there's the possiblility of it going wrong
+# And going right on 8 bit but wrong on utf8 keys.
+# And really we should also try utf8 literals in {} and => in utf8.t
+
+# Some of these tests are (effectively) duplicated in each.t
+my %comma = @comma;
+ok (keys %comma == 1, 'keys on comma hash');
+ok (values %comma == 1, 'values on comma hash');
+# defeat any tokeniser or optimiser cunning
+my $key = 'ey';
+is ($comma{"k" . $key}, "value", 'is key present? (unoptimised)');
+# now with cunning:
+is ($comma{key}, "value", 'is key present? (maybe optimised)');
+#tokeniser may treat => differently.
+my @temp = (key=>undef);
+is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)');
+
+@temp = %comma;
+ok (eq_array (\@comma, \@temp), 'list from comma hash');
+
+@temp = each %comma;
+ok (eq_array (\@comma, \@temp), 'first each from comma hash');
+@temp = each %comma;
+ok (eq_array ([], \@temp), 'last each from comma hash');
+
+my %temp = %comma;
+
+ok (keys %temp == 1, 'keys on copy of comma hash');
+ok (values %temp == 1, 'values on copy of comma hash');
+is ($temp{'k' . $key}, "value", 'is key present? (unoptimised)');
+# now with cunning:
+is ($temp{key}, "value", 'is key present? (maybe optimised)');
+@temp = (key=>undef);
+is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)');
+
+@temp = %temp;
+ok (eq_array (\@temp, \@temp), 'list from copy of comma hash');
+
+@temp = each %temp;
+ok (eq_array (\@temp, \@temp), 'first each from copy of comma hash');
+@temp = each %temp;
+ok (eq_array ([], \@temp), 'last each from copy of comma hash');
+
+my @arrow = (Key =>"Value");
+
+my %arrow = @arrow;
+ok (keys %arrow == 1, 'keys on arrow hash');
+ok (values %arrow == 1, 'values on arrow hash');
+# defeat any tokeniser or optimiser cunning
+$key = 'ey';
+is ($arrow{"K" . $key}, "Value", 'is key present? (unoptimised)');
+# now with cunning:
+is ($arrow{Key}, "Value", 'is key present? (maybe optimised)');
+#tokeniser may treat => differently.
+@temp = ('Key', undef);
+is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)');
+
+@temp = %arrow;
+ok (eq_array (\@arrow, \@temp), 'list from arrow hash');
+
+@temp = each %arrow;
+ok (eq_array (\@arrow, \@temp), 'first each from arrow hash');
+@temp = each %arrow;
+ok (eq_array ([], \@temp), 'last each from arrow hash');
+
+%temp = %arrow;
+
+ok (keys %temp == 1, 'keys on copy of arrow hash');
+ok (values %temp == 1, 'values on copy of arrow hash');
+is ($temp{'K' . $key}, "Value", 'is key present? (unoptimised)');
+# now with cunning:
+is ($temp{Key}, "Value", 'is key present? (maybe optimised)');
+@temp = ('Key', undef);
+is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)');
+
+@temp = %temp;
+ok (eq_array (\@temp, \@temp), 'list from copy of arrow hash');
+
+@temp = each %temp;
+ok (eq_array (\@temp, \@temp), 'first each from copy of arrow hash');
+@temp = each %temp;
+ok (eq_array ([], \@temp), 'last each from copy of arrow hash');
+
+my %direct = ('Camel', 2, 'Dromedary', 1);
+my %slow;
+$slow{Dromedary} = 1;
+$slow{Camel} = 2;
+
+ok (eq_hash (\%slow, \%direct), "direct list assignment to hash");
+%direct = (Camel => 2, 'Dromedary' => 1);
+ok (eq_hash (\%slow, \%direct), "direct list assignment to hash using =>");
+
+$slow{Llama} = 0; # A llama is not a camel :-)
+ok (!eq_hash (\%direct, \%slow), "different hashes should not be equal!");
+
+my (%names, %names_copy);
+%names = ('$' => 'Scalar', '@' => 'Array', # Grr '
+          '%', 'Hash', '&', 'Code');
+%names_copy = %names;
+ok (eq_hash (\%names, \%names_copy), "check we can copy our hash");
+
+sub in {
+  my %args = @_;
+  return eq_hash (\%names, \%args);
+}
+
+ok (in (%names), "pass hash into a method");
+
+sub in_method {
+  my $self = shift;
+  my %args = @_;
+  return eq_hash (\%names, \%args);
+}
+
+ok (main->in_method (%names), "pass hash into a method");
+
+sub out {
+  return %names;
+}
+%names_copy = out ();
+
+ok (eq_hash (\%names, \%names_copy), "pass hash from a subroutine");
+
+sub out_method {
+  my $self = shift;
+  return %names;
+}
+%names_copy = main->out_method ();
+
+ok (eq_hash (\%names, \%names_copy), "pass hash from a method");
+
+sub in_out {
+  my %args = @_;
+  return %args;
+}
+%names_copy = in_out (%names);
+
+ok (eq_hash (\%names, \%names_copy), "pass hash to and from a subroutine");
+
+sub in_out_method {
+  my $self = shift;
+  my %args = @_;
+  return %args;
+}
+%names_copy = main->in_out_method (%names);
+
+ok (eq_hash (\%names, \%names_copy), "pass hash to and from a method");
+
+my %names_copy2 = %names;
+ok (eq_hash (\%names, \%names_copy2), "check copy worked");
+
+# This should get ignored.
+%names_copy = ('%', 'Associative Array', %names);
+
+ok (eq_hash (\%names, \%names_copy), "duplicates at the start of a list");
+
+# This should not
+%names_copy = ('*', 'Typeglob', %names);
+
+$names_copy2{'*'} = 'Typeglob';
+ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at the end of a list");
+
+%names_copy = ('%', 'Associative Array', '*', 'Endangered species', %names,
+              '*', 'Typeglob',);
+
+ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at both ends");
+
+# And now UTF8
+
+foreach my $chr (60, 200, 600, 6000, 60000) {
+  # This little game may set a UTF8 flag internally. Or it may not. :-)
+  my ($key, $value) = (chr ($chr) . "\x{ABCD}", "$chr\x{ABCD}");
+  chop ($key, $value);
+  my @utf8c = ($key, $value);
+  my %utf8c = @utf8c;
+
+  ok (keys %utf8c == 1, 'keys on utf8 comma hash');
+  ok (values %utf8c == 1, 'values on utf8 comma hash');
+  # defeat any tokeniser or optimiser cunning
+  is ($utf8c{"" . $key}, $value, 'is key present? (unoptimised)');
+  my $tempval = sprintf '$utf8c{"\x{%x}"}', $chr;
+  is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)");
+  $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr;
+  eval $tempval or die "'$tempval' gave $@";
+  is ($utf8c{$temp[0]}, $value, 'is key present? (using LHS of $tempval)');
+
+  @temp = %utf8c;
+  ok (eq_array (\@utf8c, \@temp), 'list from utf8 comma hash');
+
+  @temp = each %utf8c;
+  ok (eq_array (\@utf8c, \@temp), 'first each from utf8 comma hash');
+  @temp = each %utf8c;
+  ok (eq_array ([], \@temp), 'last each from utf8 comma hash');
+
+  %temp = %utf8c;
+
+  ok (keys %temp == 1, 'keys on copy of utf8 comma hash');
+  ok (values %temp == 1, 'values on copy of utf8 comma hash');
+  is ($temp{"" . $key}, $value, 'is key present? (unoptimised)');
+  $tempval = sprintf '$temp{"\x{%x}"}', $chr;
+  is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)");
+  $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr;
+  eval $tempval or die "'$tempval' gave $@";
+  is ($temp{$temp[0]}, $value, "is key present? (using LHS of $tempval)");
+
+  @temp = %temp;
+  ok (eq_array (\@temp, \@temp), 'list from copy of utf8 comma hash');
+
+  @temp = each %temp;
+  ok (eq_array (\@temp, \@temp), 'first each from copy of utf8 comma hash');
+  @temp = each %temp;
+  ok (eq_array ([], \@temp), 'last each from copy of utf8 comma hash');
+
+  my $assign = sprintf '("\x{%x}" => "%d")', $chr, $chr;
+  print "# $assign\n";
+  my (@utf8a) = eval $assign;
+
+  my %utf8a = @utf8a;
+  ok (keys %utf8a == 1, 'keys on utf8 arrow hash');
+  ok (values %utf8a == 1, 'values on utf8 arrow hash');
+  # defeat any tokeniser or optimiser cunning
+  is ($utf8a{$key . ""}, $value, 'is key present? (unoptimised)');
+  $tempval = sprintf '$utf8a{"\x{%x}"}', $chr;
+  is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)");
+  $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr;
+  eval $tempval or die "'$tempval' gave $@";
+  is ($utf8a{$temp[0]}, $value, "is key present? (using LHS of $tempval)");
+
+  @temp = %utf8a;
+  ok (eq_array (\@utf8a, \@temp), 'list from utf8 arrow hash');
+
+  @temp = each %utf8a;
+  ok (eq_array (\@utf8a, \@temp), 'first each from utf8 arrow hash');
+  @temp = each %utf8a;
+  ok (eq_array ([], \@temp), 'last each from utf8 arrow hash');
+
+  %temp = %utf8a;
+
+  ok (keys %temp == 1, 'keys on copy of utf8 arrow hash');
+  ok (values %temp == 1, 'values on copy of utf8 arrow hash');
+  is ($temp{'' . $key}, $value, 'is key present? (unoptimised)');
+  $tempval = sprintf '$temp{"\x{%x}"}', $chr;
+  is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)");
+  $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr;
+  eval $tempval or die "'$tempval' gave $@";
+  is ($temp{$temp[0]}, $value, "is key present? (using LHS of $tempval)");
+
+  @temp = %temp;
+  ok (eq_array (\@temp, \@temp), 'list from copy of utf8 arrow hash');
+
+  @temp = each %temp;
+  ok (eq_array (\@temp, \@temp), 'first each from copy of utf8 arrow hash');
+  @temp = each %temp;
+  ok (eq_array ([], \@temp), 'last each from copy of utf8 arrow hash');
+
+}
+
+
diff --git a/gnu/usr.bin/perl/t/op/hashwarn.t b/gnu/usr.bin/perl/t/op/hashwarn.t
index 8466a7196e5..3db2b469175 100644
--- a/gnu/usr.bin/perl/t/op/hashwarn.t
+++ b/gnu/usr.bin/perl/t/op/hashwarn.t
@@ -45,7 +45,8 @@ sub test_warning ($$$) {
 #   print "# $num: $got\n";
 }
 
-my $odd_msg = '/^Odd number of elements in hash/';
+my $odd_msg = '/^Odd number of elements in hash assignment/';
+my $odd_msg2 = '/^Odd number of elements in anonymous hash/';
 my $ref_msg = '/^Reference found where even-sized list expected/';
 
 {
@@ -56,7 +57,7 @@ my $ref_msg = '/^Reference found where even-sized list expected/';
     test_warning 2, shift @warnings, $odd_msg;
 
     %hash = { 1..3 };
-    test_warning 3, shift @warnings, $odd_msg;
+    test_warning 3, shift @warnings, $odd_msg2;
     test_warning 4, shift @warnings, $ref_msg;
 
     %hash = [ 1..3 ];
diff --git a/gnu/usr.bin/perl/t/op/inccode.t b/gnu/usr.bin/perl/t/op/inccode.t
new file mode 100644
index 00000000000..1a3d3cf3e1a
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/inccode.t
@@ -0,0 +1,182 @@
+#!./perl -w
+
+# Tests for the coderef-in-@INC feature
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(. ../lib);
+}
+
+use File::Spec;
+
+require "test.pl";
+plan(tests => 44);
+
+my @tempfiles = ();
+
+sub get_temp_fh {
+    my $f = "DummyModule0000";
+    1 while -e ++$f;
+    push @tempfiles, $f;
+    open my $fh, ">$f" or die "Can't create $f: $!";
+    print $fh "package ".substr($_[0],0,-3)."; 1;";
+    close $fh or die "Couldn't close: $!";
+    open $fh, $f or die "Can't open $f: $!";
+    return $fh;
+}
+
+END { 1 while unlink @tempfiles }
+
+sub fooinc {
+    my ($self, $filename) = @_;
+    if (substr($filename,0,3) eq 'Foo') {
+	return get_temp_fh($filename);
+    }
+    else {
+        return undef;
+    }
+}
+
+push @INC, \&fooinc;
+
+my $evalret = eval { require Bar; 1 };
+ok( !$evalret,      'Trying non-magic package' );
+
+$evalret = eval { require Foo; 1 };
+die $@ if $@;
+ok( $evalret,                      'require Foo; magic via code ref'  );
+ok( exists $INC{'Foo.pm'},         '  %INC sees Foo.pm' );
+is( ref $INC{'Foo.pm'}, 'CODE',    '  val Foo.pm is a coderef in %INC' );
+is( $INC{'Foo.pm'}, \&fooinc,	   '  val Foo.pm is correct in %INC' );
+
+$evalret = eval "use Foo1; 1;";
+die $@ if $@;
+ok( $evalret,                      'use Foo1' );
+ok( exists $INC{'Foo1.pm'},        '  %INC sees Foo1.pm' );
+is( ref $INC{'Foo1.pm'}, 'CODE',   '  val Foo1.pm is a coderef in %INC' );
+is( $INC{'Foo1.pm'}, \&fooinc,     '  val Foo1.pm is correct in %INC' );
+
+$evalret = eval { do 'Foo2.pl'; 1 };
+die $@ if $@;
+ok( $evalret,                      'do "Foo2.pl"' );
+ok( exists $INC{'Foo2.pl'},        '  %INC sees Foo2.pl' );
+is( ref $INC{'Foo2.pl'}, 'CODE',   '  val Foo2.pl is a coderef in %INC' );
+is( $INC{'Foo2.pl'}, \&fooinc,     '  val Foo2.pl is correct in %INC' );
+
+pop @INC;
+
+
+sub fooinc2 {
+    my ($self, $filename) = @_;
+    if (substr($filename, 0, length($self->[1])) eq $self->[1]) {
+	return get_temp_fh($filename);
+    }
+    else {
+        return undef;
+    }
+}
+
+my $arrayref = [ \&fooinc2, 'Bar' ];
+push @INC, $arrayref;
+
+$evalret = eval { require Foo; 1; };
+die $@ if $@;
+ok( $evalret,                     'Originally loaded packages preserved' );
+$evalret = eval { require Foo3; 1; };
+ok( !$evalret,                    'Original magic INC purged' );
+
+$evalret = eval { require Bar; 1 };
+die $@ if $@;
+ok( $evalret,                     'require Bar; magic via array ref' );
+ok( exists $INC{'Bar.pm'},        '  %INC sees Bar.pm' );
+is( ref $INC{'Bar.pm'}, 'ARRAY',  '  val Bar.pm is an arrayref in %INC' );
+is( $INC{'Bar.pm'}, $arrayref,    '  val Bar.pm is correct in %INC' );
+
+ok( eval "use Bar1; 1;",          'use Bar1' );
+ok( exists $INC{'Bar1.pm'},       '  %INC sees Bar1.pm' );
+is( ref $INC{'Bar1.pm'}, 'ARRAY', '  val Bar1.pm is an arrayref in %INC' );
+is( $INC{'Bar1.pm'}, $arrayref,   '  val Bar1.pm is correct in %INC' );
+
+ok( eval { do 'Bar2.pl'; 1 },     'do "Bar2.pl"' );
+ok( exists $INC{'Bar2.pl'},       '  %INC sees Bar2.pl' );
+is( ref $INC{'Bar2.pl'}, 'ARRAY', '  val Bar2.pl is an arrayref in %INC' );
+is( $INC{'Bar2.pl'}, $arrayref,   '  val Bar2.pl is correct in %INC' );
+
+pop @INC;
+
+sub FooLoader::INC {
+    my ($self, $filename) = @_;
+    if (substr($filename,0,4) eq 'Quux') {
+	return get_temp_fh($filename);
+    }
+    else {
+        return undef;
+    }
+}
+
+my $href = bless( {}, 'FooLoader' );
+push @INC, $href;
+
+$evalret = eval { require Quux; 1 };
+die $@ if $@;
+ok( $evalret,                      'require Quux; magic via hash object' );
+ok( exists $INC{'Quux.pm'},        '  %INC sees Quux.pm' );
+is( ref $INC{'Quux.pm'}, 'FooLoader',
+				   '  val Quux.pm is an object in %INC' );
+is( $INC{'Quux.pm'}, $href,        '  val Quux.pm is correct in %INC' );
+
+pop @INC;
+
+my $aref = bless( [], 'FooLoader' );
+push @INC, $aref;
+
+$evalret = eval { require Quux1; 1 };
+die $@ if $@;
+ok( $evalret,                      'require Quux1; magic via array object' );
+ok( exists $INC{'Quux1.pm'},       '  %INC sees Quux1.pm' );
+is( ref $INC{'Quux1.pm'}, 'FooLoader',
+				   '  val Quux1.pm is an object in %INC' );
+is( $INC{'Quux1.pm'}, $aref,       '  val Quux1.pm  is correct in %INC' );
+
+pop @INC;
+
+my $sref = bless( \(my $x = 1), 'FooLoader' );
+push @INC, $sref;
+
+$evalret = eval { require Quux2; 1 };
+die $@ if $@;
+ok( $evalret,                      'require Quux2; magic via scalar object' );
+ok( exists $INC{'Quux2.pm'},       '  %INC sees Quux2.pm' );
+is( ref $INC{'Quux2.pm'}, 'FooLoader',
+				   '  val Quux2.pm is an object in %INC' );
+is( $INC{'Quux2.pm'}, $sref,       '  val Quux2.pm is correct in %INC' );
+
+pop @INC;
+
+push @INC, sub {
+    my ($self, $filename) = @_;
+    if (substr($filename,0,4) eq 'Toto') {
+	$INC{$filename} = 'xyz';
+	return get_temp_fh($filename);
+    }
+    else {
+        return undef;
+    }
+};
+
+$evalret = eval { require Toto; 1 };
+die $@ if $@;
+ok( $evalret,                      'require Toto; magic via anonymous code ref'  );
+ok( exists $INC{'Toto.pm'},        '  %INC sees Toto.pm' );
+ok( ! ref $INC{'Toto.pm'},         q/  val Toto.pm isn't a ref in %INC/ );
+is( $INC{'Toto.pm'}, 'xyz',	   '  val Toto.pm is correct in %INC' );
+
+pop @INC;
+
+my $filename = $^O eq 'MacOS' ? ':Foo:Foo.pm' : './Foo.pm';
+{
+    local @INC;
+    @INC = sub { $filename = 'seen'; return undef; };
+    eval { require $filename; };
+    is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' );
+}
diff --git a/gnu/usr.bin/perl/t/op/lc.t b/gnu/usr.bin/perl/t/op/lc.t
new file mode 100644
index 00000000000..1fbb3e1afbf
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/lc.t
@@ -0,0 +1,138 @@
+#!./perl
+
+print "1..51\n";
+
+my $test = 1;
+
+sub ok {
+    if ($_[0]) {
+	if ($_[1]) {
+	    print "ok $test - $_[1]\n";
+	} else {
+	    print "ok $test\n";
+	}
+    } else {
+	if ($_[1]) {
+	    print "not ok $test - $_[1]\n";
+	} else {
+	    print "not ok $test\n";
+	}
+    }
+    $test++;
+}
+
+$a = "HELLO.* world";
+$b = "hello.* WORLD";
+
+ok("\Q$a\E."      eq "HELLO\\.\\*\\ world.", '\Q\E HELLO.* world');
+ok("\u$a"         eq "HELLO\.\* world",      '\u');
+ok("\l$a"         eq "hELLO\.\* world",      '\l');
+ok("\U$a"         eq "HELLO\.\* WORLD",      '\U');
+ok("\L$a"         eq "hello\.\* world",      '\L');
+
+ok(quotemeta($a)  eq "HELLO\\.\\*\\ world",  'quotemeta');
+ok(ucfirst($a)    eq "HELLO\.\* world",      'ucfirst');
+ok(lcfirst($a)    eq "hELLO\.\* world",      'lcfirst');
+ok(uc($a)         eq "HELLO\.\* WORLD",      'uc');
+ok(lc($a)         eq "hello\.\* world",      'lc');
+
+ok("\Q$b\E."      eq "hello\\.\\*\\ WORLD.", '\Q\E hello.* WORLD');
+ok("\u$b"         eq "Hello\.\* WORLD",      '\u');
+ok("\l$b"         eq "hello\.\* WORLD",      '\l');
+ok("\U$b"         eq "HELLO\.\* WORLD",      '\U');
+ok("\L$b"         eq "hello\.\* world",      '\L');
+
+ok(quotemeta($b)  eq "hello\\.\\*\\ WORLD",  'quotemeta');
+ok(ucfirst($b)    eq "Hello\.\* WORLD",      'ucfirst');
+ok(lcfirst($b)    eq "hello\.\* WORLD",      'lcfirst');
+ok(uc($b)         eq "HELLO\.\* WORLD",      'uc');
+ok(lc($b)         eq "hello\.\* world",      'lc');
+
+# \x{100} is LATIN CAPITAL LETTER A WITH MACRON; its bijective lowercase is
+# \x{101}, LATIN SMALL LETTER A WITH MACRON.
+
+$a = "\x{100}\x{101}Aa";
+$b = "\x{101}\x{100}aA";
+
+ok("\Q$a\E."      eq "\x{100}\x{101}Aa.", '\Q\E \x{100}\x{101}Aa');
+ok("\u$a"         eq "\x{100}\x{101}Aa",  '\u');
+ok("\l$a"         eq "\x{101}\x{101}Aa",  '\l');
+ok("\U$a"         eq "\x{100}\x{100}AA",  '\U');
+ok("\L$a"         eq "\x{101}\x{101}aa",  '\L');
+
+ok(quotemeta($a)  eq "\x{100}\x{101}Aa",  'quotemeta');
+ok(ucfirst($a)    eq "\x{100}\x{101}Aa",  'ucfirst');
+ok(lcfirst($a)    eq "\x{101}\x{101}Aa",  'lcfirst');
+ok(uc($a)         eq "\x{100}\x{100}AA",  'uc');
+ok(lc($a)         eq "\x{101}\x{101}aa",  'lc');
+
+ok("\Q$b\E."      eq "\x{101}\x{100}aA.", '\Q\E \x{101}\x{100}aA');
+ok("\u$b"         eq "\x{100}\x{100}aA",  '\u');
+ok("\l$b"         eq "\x{101}\x{100}aA",  '\l');
+ok("\U$b"         eq "\x{100}\x{100}AA",  '\U');
+ok("\L$b"         eq "\x{101}\x{101}aa",  '\L');
+
+ok(quotemeta($b)  eq "\x{101}\x{100}aA",  'quotemeta');
+ok(ucfirst($b)    eq "\x{100}\x{100}aA",  'ucfirst');
+ok(lcfirst($b)    eq "\x{101}\x{100}aA",  'lcfirst');
+ok(uc($b)         eq "\x{100}\x{100}AA",  'uc');
+ok(lc($b)         eq "\x{101}\x{101}aa",  'lc');
+
+# \x{DF} is LATIN SMALL LETTER SHARP S, its uppercase is SS or \x{53}\x{53};
+# \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its uppercase is
+# \x{2BC}\x{E4} or MODIFIER LETTER APOSTROPHE and N.
+
+# In EBCDIC \x{DF} is LATIN SMALL LETTER Y WITH DIAERESIS,
+# and it's uppercase is \x{178}, LATIN CAPITAL LETTER Y WITH DIAERESIS.
+
+if (ord("A") == 193) { # EBCDIC
+    ok("\U\x{DF}aB\x{149}cD" eq "\x{178}AB\x{2BC}NCD",
+       "multicharacter uppercase");
+} elsif (ord("A") == 65) {
+    ok("\U\x{DF}aB\x{149}cD" eq "SSAB\x{2BC}NCD",
+       "multicharacter uppercase");
+} else {
+    ok(0, "what is your encoding?");
+}
+
+# The \x{DF} is its own lowercase, ditto for \x{149}.
+# There are no single character -> multiple characters lowercase mappings.
+
+if (ord("A") == 193) { # EBCDIC
+    ok("\LaB\x{149}cD" eq "ab\x{149}cd",
+       "multicharacter lowercase");
+} elsif (ord("A") == 65) {
+    ok("\L\x{DF}aB\x{149}cD" eq "\x{DF}ab\x{149}cd",
+       "multicharacter lowercase");
+} else {
+    ok(0, "what is your encoding?");
+}
+
+# titlecase is used for \u / ucfirst.
+
+# \x{587} is ARMENIAN SMALL LIGATURE ECH YIWN and its titlecase is
+# \x{535}\x{582} ARMENIAN CAPITAL LETTER ECH + ARMENIAN SMALL LETTER YIWN
+# while its lowercase is 
+# \x{587} itself
+# and its uppercase is
+# \x{535}\x{552} ARMENIAN CAPITAL LETTER ECH + ARMENIAN CAPITAL LETTER YIWN
+
+$a = "\x{587}";
+
+ok("\L\x{587}" eq "\x{587}",        "ligature lowercase");
+ok("\u\x{587}" eq "\x{535}\x{582}", "ligature titlecase");
+ok("\U\x{587}" eq "\x{535}\x{552}", "ligature uppercase");
+
+# mktables had problems where many-to-one case mappings didn't work right.
+# The lib/unifold.t should give the fourth folding, "casefolding", a good
+# workout.
+
+ok(lc("\x{1C4}") eq "\x{1C6}",      "U+01C4 lc is U+01C6");
+ok(lc("\x{1C5}") eq "\x{1C6}",      "U+01C5 lc is U+01C6, too");
+
+ok(ucfirst("\x{3C2}") eq "\x{3A3}", "U+03C2 ucfirst is U+03A3");
+ok(ucfirst("\x{3C3}") eq "\x{3A3}", "U+03C3 ucfirst is U+03A3, too");
+
+ok(uc("\x{1C5}") eq "\x{1C4}",      "U+01C5 uc is U+01C4");
+ok(uc("\x{1C6}") eq "\x{1C4}",      "U+01C6 uc is U+01C4, too");
+
diff --git a/gnu/usr.bin/perl/t/op/length.t b/gnu/usr.bin/perl/t/op/length.t
index ceb005ecc4a..d1cfda1da6c 100644
--- a/gnu/usr.bin/perl/t/op/length.t
+++ b/gnu/usr.bin/perl/t/op/length.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..13\n";
+print "1..15\n";
 
 print "not " unless length("")    == 0;
 print "ok 1\n";
@@ -33,53 +33,103 @@ print "ok 3\n";
 }
 
 {
-    my $a = "\x{80}";
-    
+    my $a = pack("U", 0xFF);
+
     print "not " unless length($a) == 1;
     print "ok 6\n";
     $test++;
-    
+
     use bytes;
-    print "not " unless $a eq "\xc2\x80" && length($a) == 2;
+    if (ord('A') == 193)
+     {
+      printf "#%vx for 0xFF\n",$a;
+      print "not " unless $a eq "\x8b\x73" && length($a) == 2;
+     }
+    else
+     {
+      print "not " unless $a eq "\xc3\xbf" && length($a) == 2;
+     }
     print "ok 7\n";
     $test++;
 }
 
 {
     my $a = "\x{100}";
-    
+
     print "not " unless length($a) == 1;
     print "ok 8\n";
     $test++;
-    
+
     use bytes;
-    print "not " unless $a eq "\xc4\x80" && length($a) == 2;
+    if (ord('A') == 193)
+     {
+      printf "#%vx for 0x100\n",$a;
+      print "not " unless $a eq "\x8c\x41" && length($a) == 2;
+     }
+    else
+     {
+      print "not " unless $a eq "\xc4\x80" && length($a) == 2;
+     }
     print "ok 9\n";
     $test++;
 }
 
 {
     my $a = "\x{100}\x{80}";
-    
+
     print "not " unless length($a) == 2;
     print "ok 10\n";
     $test++;
-    
+
     use bytes;
-    print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4;
+    if (ord('A') == 193)
+     {
+      printf "#%vx for 0x100 0x80\n",$a;
+      print "not " unless $a eq "\x8c\x41\x8a\x67" && length($a) == 4;
+     }
+    else
+     {
+      print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4;
+     }
     print "ok 11\n";
     $test++;
 }
 
 {
     my $a = "\x{80}\x{100}";
-    
+
     print "not " unless length($a) == 2;
     print "ok 12\n";
     $test++;
-    
+
     use bytes;
-    print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4;
+    if (ord('A') == 193)
+     {
+      printf "#%vx for 0x80 0x100\n",$a;
+      print "not " unless $a eq "\x8a\x67\x8c\x41" && length($a) == 4;
+     }
+    else
+     {
+      print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4;
+     }
     print "ok 13\n";
     $test++;
 }
+
+# Now for Unicode with magical vtbls
+
+{
+    require Tie::Scalar;
+    my $a;
+    tie $a, 'Tie::StdScalar';  # makes $a magical
+    $a = "\x{263A}";
+    
+    print "not " unless length($a) == 1;
+    print "ok 14\n";
+    $test++;
+
+    use bytes;
+    print "not " unless length($a) == 3;
+    print "ok 15\n";
+    $test++;
+}
diff --git a/gnu/usr.bin/perl/t/op/lex_assign.t b/gnu/usr.bin/perl/t/op/lex_assign.t
index d761f73ce7c..fb9fe4e95c0 100644
--- a/gnu/usr.bin/perl/t/op/lex_assign.t
+++ b/gnu/usr.bin/perl/t/op/lex_assign.t
@@ -5,6 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
+$| = 1;
 umask 0;
 $xref = \ "";
 $runme = ($^O eq 'VMS' ? 'MCR ' : '') . $^X;
diff --git a/gnu/usr.bin/perl/t/op/lfs.t b/gnu/usr.bin/perl/t/op/lfs.t
index 0a1c3998401..8be24f4d82a 100644
--- a/gnu/usr.bin/perl/t/op/lfs.t
+++ b/gnu/usr.bin/perl/t/op/lfs.t
@@ -1,6 +1,6 @@
 # NOTE: this file tests how large files (>2GB) work with perlio (stdio/sfio).
 # sysopen(), sysseek(), syswrite(), sysread() are tested in t/lib/syslfs.t.
-# If you modify/add tests here, remember to update also t/lib/syslfs.t.
+# If you modify/add tests here, remember to update also ext/Fcntl/t/syslfs.t.
 
 BEGIN {
 	chdir 't' if -d 't';
@@ -54,10 +54,12 @@ EOM
     print "1..0 # Skip: @_\n" if @_;
 }
 
+$| = 1;
+
 print "# checking whether we have sparse files...\n";
 
 # Known have-nots.
-if ($^O eq 'MSWin32' || $^O eq 'VMS') {
+if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
     print "1..0 # Skip: no sparse files in $^O\n";
     bye();
 }
diff --git a/gnu/usr.bin/perl/t/op/loopctl.t b/gnu/usr.bin/perl/t/op/loopctl.t
new file mode 100644
index 00000000000..2ed9df1432b
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/loopctl.t
@@ -0,0 +1,946 @@
+#!./perl
+
+# We have the following types of loop:
+#
+# 1a)  while(A) {B}
+# 1b)  B while A;
+#
+# 2a)  until(A) {B}
+# 2b)  B until A;
+#
+# 3a)  for(@A)  {B}
+# 3b)  B for A;
+#
+# 4a)  for (A;B;C) {D}
+#
+# 5a)  { A }        # a bare block is a loop which runs once
+#
+# Loops of type (b) don't allow for next/last/redo style
+#  control, so we ignore them here. Type (a) loops can
+#  all be labelled, so there are ten possibilities (each
+#  of 5 types, labelled/unlabelled). We therefore need
+#  thirty tests to try the three control statements against
+#  the ten types of loop. For the first four types it's useful
+#  to distinguish the case where next re-iterates from the case
+#  where it leaves the loop. That makes 38.
+# All these tests rely on "last LABEL"
+#  so if they've *all* failed, maybe you broke that...
+#
+# These tests are followed by an extra test of nested loops.
+# Feel free to add more here.
+#
+#  -- .robin. <robin@kitsite.com>  2001-03-13
+
+print "1..41\n";
+
+my $ok;
+
+## while() loop without a label
+
+TEST1: { # redo
+
+  $ok = 0;
+
+  my $x = 1;
+  my $first_time = 1;
+  while($x--) {
+    if (!$first_time) {
+      $ok = 1;
+      last TEST1;
+    }
+    $ok = 0;
+    $first_time = 0;
+    redo;
+    last TEST1;
+  }
+  continue {
+    $ok = 0;
+    last TEST1;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 1\n" : "not ok 1\n");
+
+TEST2: { # next (succesful)
+
+  $ok = 0;
+
+  my $x = 2;
+  my $first_time = 1;
+  my $been_in_continue = 0;
+  while($x--) {
+    if (!$first_time) {
+      $ok = $been_in_continue;
+      last TEST2;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next;
+    last TEST2;
+  }
+  continue {
+    $been_in_continue = 1;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 2\n" : "not ok 2\n");
+
+TEST3: { # next (unsuccesful)
+
+  $ok = 0;
+
+  my $x = 1;
+  my $first_time = 1;
+  my $been_in_loop = 0;
+  my $been_in_continue = 0;
+  while($x--) {
+    $been_in_loop = 1;
+    if (!$first_time) {
+      $ok = 0;
+      last TEST3;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next;
+    last TEST3;
+  }
+  continue {
+    $been_in_continue = 1;
+  }
+  $ok = $been_in_loop && $been_in_continue;
+}
+print ($ok ? "ok 3\n" : "not ok 3\n");
+
+TEST4: { # last
+
+  $ok = 0;
+
+  my $x = 1;
+  my $first_time = 1;
+  while($x++) {
+    if (!$first_time) {
+      $ok = 0;
+      last TEST4;
+    }
+    $ok = 0;
+    $first_time = 0;
+    last;
+    last TEST4;
+  }
+  continue {
+    $ok = 0;
+    last TEST4;
+  }
+  $ok = 1;
+}
+print ($ok ? "ok 4\n" : "not ok 4\n");
+
+
+## until() loop without a label
+
+TEST5: { # redo
+
+  $ok = 0;
+
+  my $x = 0;
+  my $first_time = 1;
+  until($x++) {
+    if (!$first_time) {
+      $ok = 1;
+      last TEST5;
+    }
+    $ok = 0;
+    $first_time = 0;
+    redo;
+    last TEST5;
+  }
+  continue {
+    $ok = 0;
+    last TEST5;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 5\n" : "not ok 5\n");
+
+TEST6: { # next (succesful)
+
+  $ok = 0;
+
+  my $x = 0;
+  my $first_time = 1;
+  my $been_in_continue = 0;
+  until($x++ >= 2) {
+    if (!$first_time) {
+      $ok = $been_in_continue;
+      last TEST6;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next;
+    last TEST6;
+  }
+  continue {
+    $been_in_continue = 1;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 6\n" : "not ok 6\n");
+
+TEST7: { # next (unsuccesful)
+
+  $ok = 0;
+
+  my $x = 0;
+  my $first_time = 1;
+  my $been_in_loop = 0;
+  my $been_in_continue = 0;
+  until($x++) {
+    $been_in_loop = 1;
+    if (!$first_time) {
+      $ok = 0;
+      last TEST7;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next;
+    last TEST7;
+  }
+  continue {
+    $been_in_continue = 1;
+  }
+  $ok = $been_in_loop && $been_in_continue;
+}
+print ($ok ? "ok 7\n" : "not ok 7\n");
+
+TEST8: { # last
+
+  $ok = 0;
+
+  my $x = 0;
+  my $first_time = 1;
+  until($x++ == 10) {
+    if (!$first_time) {
+      $ok = 0;
+      last TEST8;
+    }
+    $ok = 0;
+    $first_time = 0;
+    last;
+    last TEST8;
+  }
+  continue {
+    $ok = 0;
+    last TEST8;
+  }
+  $ok = 1;
+}
+print ($ok ? "ok 8\n" : "not ok 8\n");
+
+## for(@array) loop without a label
+
+TEST9: { # redo
+
+  $ok = 0;
+
+  my $first_time = 1;
+  for(1) {
+    if (!$first_time) {
+      $ok = 1;
+      last TEST9;
+    }
+    $ok = 0;
+    $first_time = 0;
+    redo;
+    last TEST9;
+  }
+  continue {
+    $ok = 0;
+    last TEST9;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 9\n" : "not ok 9\n");
+
+TEST10: { # next (succesful)
+
+  $ok = 0;
+
+  my $first_time = 1;
+  my $been_in_continue = 0;
+  for(1,2) {
+    if (!$first_time) {
+      $ok = $been_in_continue;
+      last TEST10;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next;
+    last TEST10;
+  }
+  continue {
+    $been_in_continue = 1;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 10\n" : "not ok 10\n");
+
+TEST11: { # next (unsuccesful)
+
+  $ok = 0;
+
+  my $first_time = 1;
+  my $been_in_loop = 0;
+  my $been_in_continue = 0;
+  for(1) {
+    $been_in_loop = 1;
+    if (!$first_time) {
+      $ok = 0;
+      last TEST11;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next;
+    last TEST11;
+  }
+  continue {
+    $been_in_continue = 1;
+  }
+  $ok = $been_in_loop && $been_in_continue;
+}
+print ($ok ? "ok 11\n" : "not ok 11\n");
+
+TEST12: { # last
+
+  $ok = 0;
+
+  my $first_time = 1;
+  for(1..10) {
+    if (!$first_time) {
+      $ok = 0;
+      last TEST12;
+    }
+    $ok = 0;
+    $first_time = 0;
+    last;
+    last TEST12;
+  }
+  continue {
+    $ok=0;
+    last TEST12;
+  }
+  $ok = 1;
+}
+print ($ok ? "ok 12\n" : "not ok 12\n");
+
+## for(;;) loop without a label
+
+TEST13: { # redo
+
+  $ok = 0;
+
+  for(my $first_time = 1; 1;) {
+    if (!$first_time) {
+      $ok = 1;
+      last TEST13;
+    }
+    $ok = 0;
+    $first_time=0;
+
+    redo;
+    last TEST13;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 13\n" : "not ok 13\n");
+
+TEST14: { # next (successful)
+
+  $ok = 0;
+
+  for(my $first_time = 1; 1; $first_time=0) {
+    if (!$first_time) {
+      $ok = 1;
+      last TEST14;
+    }
+    $ok = 0;
+    next;
+    last TEST14;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 14\n" : "not ok 14\n");
+
+TEST15: { # next (unsuccesful)
+
+  $ok = 0;
+
+  my $x=1;
+  my $been_in_loop = 0;
+  for(my $first_time = 1; $x--;) {
+    $been_in_loop = 1;
+    if (!$first_time) {
+      $ok = 0;
+      last TEST15;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next;
+    last TEST15;
+  }
+  $ok = $been_in_loop;
+}
+print ($ok ? "ok 15\n" : "not ok 15\n");
+
+TEST16: { # last
+
+  $ok = 0;
+
+  for(my $first_time = 1; 1; last TEST16) {
+    if (!$first_time) {
+      $ok = 0;
+      last TEST16;
+    }
+    $ok = 0;
+    $first_time = 0;
+    last;
+    last TEST16;
+  }
+  $ok = 1;
+}
+print ($ok ? "ok 16\n" : "not ok 16\n");
+
+## bare block without a label
+
+TEST17: { # redo
+
+  $ok = 0;
+  my $first_time = 1;
+
+  {
+    if (!$first_time) {
+      $ok = 1;
+      last TEST17;
+    }
+    $ok = 0;
+    $first_time=0;
+
+    redo;
+    last TEST17;
+  }
+  continue {
+    $ok = 0;
+    last TEST17;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 17\n" : "not ok 17\n");
+
+TEST18: { # next
+
+  $ok = 0;
+  {
+    next;
+    last TEST18;
+  }
+  continue {
+    $ok = 1;
+    last TEST18;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 18\n" : "not ok 18\n");
+
+TEST19: { # last
+
+  $ok = 0;
+  {
+    last;
+    last TEST19;
+  }
+  continue {
+    $ok = 0;
+    last TEST19;
+  }
+  $ok = 1;
+}
+print ($ok ? "ok 19\n" : "not ok 19\n");
+
+
+### Now do it all again with labels
+
+## while() loop with a label
+
+TEST20: { # redo
+
+  $ok = 0;
+
+  my $x = 1;
+  my $first_time = 1;
+  LABEL20: while($x--) {
+    if (!$first_time) {
+      $ok = 1;
+      last TEST20;
+    }
+    $ok = 0;
+    $first_time = 0;
+    redo LABEL20;
+    last TEST20;
+  }
+  continue {
+    $ok = 0;
+    last TEST20;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 20\n" : "not ok 20\n");
+
+TEST21: { # next (succesful)
+
+  $ok = 0;
+
+  my $x = 2;
+  my $first_time = 1;
+  my $been_in_continue = 0;
+  LABEL21: while($x--) {
+    if (!$first_time) {
+      $ok = $been_in_continue;
+      last TEST21;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next LABEL21;
+    last TEST21;
+  }
+  continue {
+    $been_in_continue = 1;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 21\n" : "not ok 21\n");
+
+TEST22: { # next (unsuccesful)
+
+  $ok = 0;
+
+  my $x = 1;
+  my $first_time = 1;
+  my $been_in_loop = 0;
+  my $been_in_continue = 0;
+  LABEL22: while($x--) {
+    $been_in_loop = 1;
+    if (!$first_time) {
+      $ok = 0;
+      last TEST22;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next LABEL22;
+    last TEST22;
+  }
+  continue {
+    $been_in_continue = 1;
+  }
+  $ok = $been_in_loop && $been_in_continue;
+}
+print ($ok ? "ok 22\n" : "not ok 22\n");
+
+TEST23: { # last
+
+  $ok = 0;
+
+  my $x = 1;
+  my $first_time = 1;
+  LABEL23: while($x++) {
+    if (!$first_time) {
+      $ok = 0;
+      last TEST23;
+    }
+    $ok = 0;
+    $first_time = 0;
+    last LABEL23;
+    last TEST23;
+  }
+  continue {
+    $ok = 0;
+    last TEST23;
+  }
+  $ok = 1;
+}
+print ($ok ? "ok 23\n" : "not ok 23\n");
+
+
+## until() loop with a label
+
+TEST24: { # redo
+
+  $ok = 0;
+
+  my $x = 0;
+  my $first_time = 1;
+  LABEL24: until($x++) {
+    if (!$first_time) {
+      $ok = 1;
+      last TEST24;
+    }
+    $ok = 0;
+    $first_time = 0;
+    redo LABEL24;
+    last TEST24;
+  }
+  continue {
+    $ok = 0;
+    last TEST24;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 24\n" : "not ok 24\n");
+
+TEST25: { # next (succesful)
+
+  $ok = 0;
+
+  my $x = 0;
+  my $first_time = 1;
+  my $been_in_continue = 0;
+  LABEL25: until($x++ >= 2) {
+    if (!$first_time) {
+      $ok = $been_in_continue;
+      last TEST25;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next LABEL25;
+    last TEST25;
+  }
+  continue {
+    $been_in_continue = 1;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 25\n" : "not ok 25\n");
+
+TEST26: { # next (unsuccesful)
+
+  $ok = 0;
+
+  my $x = 0;
+  my $first_time = 1;
+  my $been_in_loop = 0;
+  my $been_in_continue = 0;
+  LABEL26: until($x++) {
+    $been_in_loop = 1;
+    if (!$first_time) {
+      $ok = 0;
+      last TEST26;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next LABEL26;
+    last TEST26;
+  }
+  continue {
+    $been_in_continue = 1;
+  }
+  $ok = $been_in_loop && $been_in_continue;
+}
+print ($ok ? "ok 26\n" : "not ok 26\n");
+
+TEST27: { # last
+
+  $ok = 0;
+
+  my $x = 0;
+  my $first_time = 1;
+  LABEL27: until($x++ == 10) {
+    if (!$first_time) {
+      $ok = 0;
+      last TEST27;
+    }
+    $ok = 0;
+    $first_time = 0;
+    last LABEL27;
+    last TEST27;
+  }
+  continue {
+    $ok = 0;
+    last TEST8;
+  }
+  $ok = 1;
+}
+print ($ok ? "ok 27\n" : "not ok 27\n");
+
+## for(@array) loop with a label
+
+TEST28: { # redo
+
+  $ok = 0;
+
+  my $first_time = 1;
+  LABEL28: for(1) {
+    if (!$first_time) {
+      $ok = 1;
+      last TEST28;
+    }
+    $ok = 0;
+    $first_time = 0;
+    redo LABEL28;
+    last TEST28;
+  }
+  continue {
+    $ok = 0;
+    last TEST28;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 28\n" : "not ok 28\n");
+
+TEST29: { # next (succesful)
+
+  $ok = 0;
+
+  my $first_time = 1;
+  my $been_in_continue = 0;
+  LABEL29: for(1,2) {
+    if (!$first_time) {
+      $ok = $been_in_continue;
+      last TEST29;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next LABEL29;
+    last TEST29;
+  }
+  continue {
+    $been_in_continue = 1;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 29\n" : "not ok 29\n");
+
+TEST30: { # next (unsuccesful)
+
+  $ok = 0;
+
+  my $first_time = 1;
+  my $been_in_loop = 0;
+  my $been_in_continue = 0;
+  LABEL30: for(1) {
+    $been_in_loop = 1;
+    if (!$first_time) {
+      $ok = 0;
+      last TEST30;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next LABEL30;
+    last TEST30;
+  }
+  continue {
+    $been_in_continue = 1;
+  }
+  $ok = $been_in_loop && $been_in_continue;
+}
+print ($ok ? "ok 30\n" : "not ok 30\n");
+
+TEST31: { # last
+
+  $ok = 0;
+
+  my $first_time = 1;
+  LABEL31: for(1..10) {
+    if (!$first_time) {
+      $ok = 0;
+      last TEST31;
+    }
+    $ok = 0;
+    $first_time = 0;
+    last LABEL31;
+    last TEST31;
+  }
+  continue {
+    $ok=0;
+    last TEST31;
+  }
+  $ok = 1;
+}
+print ($ok ? "ok 31\n" : "not ok 31\n");
+
+## for(;;) loop with a label
+
+TEST32: { # redo
+
+  $ok = 0;
+
+  LABEL32: for(my $first_time = 1; 1;) {
+    if (!$first_time) {
+      $ok = 1;
+      last TEST32;
+    }
+    $ok = 0;
+    $first_time=0;
+
+    redo LABEL32;
+    last TEST32;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 32\n" : "not ok 32\n");
+
+TEST33: { # next (successful)
+
+  $ok = 0;
+
+  LABEL33: for(my $first_time = 1; 1; $first_time=0) {
+    if (!$first_time) {
+      $ok = 1;
+      last TEST33;
+    }
+    $ok = 0;
+    next LABEL33;
+    last TEST33;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 33\n" : "not ok 33\n");
+
+TEST34: { # next (unsuccesful)
+
+  $ok = 0;
+
+  my $x=1;
+  my $been_in_loop = 0;
+  LABEL34: for(my $first_time = 1; $x--;) {
+    $been_in_loop = 1;
+    if (!$first_time) {
+      $ok = 0;
+      last TEST34;
+    }
+    $ok = 0;
+    $first_time = 0;
+    next LABEL34;
+    last TEST34;
+  }
+  $ok = $been_in_loop;
+}
+print ($ok ? "ok 34\n" : "not ok 34\n");
+
+TEST35: { # last
+
+  $ok = 0;
+
+  LABEL35: for(my $first_time = 1; 1; last TEST16) {
+    if (!$first_time) {
+      $ok = 0;
+      last TEST35;
+    }
+    $ok = 0;
+    $first_time = 0;
+    last LABEL35;
+    last TEST35;
+  }
+  $ok = 1;
+}
+print ($ok ? "ok 35\n" : "not ok 35\n");
+
+## bare block with a label
+
+TEST36: { # redo
+
+  $ok = 0;
+  my $first_time = 1;
+
+  LABEL36: {
+    if (!$first_time) {
+      $ok = 1;
+      last TEST36;
+    }
+    $ok = 0;
+    $first_time=0;
+
+    redo LABEL36;
+    last TEST36;
+  }
+  continue {
+    $ok = 0;
+    last TEST36;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 36\n" : "not ok 36\n");
+
+TEST37: { # next
+
+  $ok = 0;
+  LABEL37: {
+    next LABEL37;
+    last TEST37;
+  }
+  continue {
+    $ok = 1;
+    last TEST37;
+  }
+  $ok = 0;
+}
+print ($ok ? "ok 37\n" : "not ok 37\n");
+
+TEST38: { # last
+
+  $ok = 0;
+  LABEL38: {
+    last LABEL38;
+    last TEST38;
+  }
+  continue {
+    $ok = 0;
+    last TEST38;
+  }
+  $ok = 1;
+}
+print ($ok ? "ok 38\n" : "not ok 38\n");
+
+### Now test nested constructs
+
+TEST39: {
+    $ok = 0;
+    my ($x, $y, $z) = (1,1,1);
+    one39: while ($x--) {
+      $ok = 0;
+      two39: while ($y--) {
+        $ok = 0;
+        three39: while ($z--) {
+           next two39;
+        }
+        continue {
+          $ok = 0;
+          last TEST39;
+        }
+      }
+      continue {
+        $ok = 1;
+        last TEST39;
+      }
+      $ok = 0;
+    }
+}
+print ($ok ? "ok 39\n" : "not ok 39\n");
+
+
+### Test that loop control is dynamicly scoped.
+
+sub test_last_label { last TEST40 }
+
+TEST40: {
+    $ok = 1;
+    test_last_label();
+    $ok = 0;
+}
+print ($ok ? "ok 40\n" : "not ok 40\n");
+
+sub test_last { last }
+
+TEST41: {
+    $ok = 1;
+    test_last();
+    $ok = 0;
+}
+print ($ok ? "ok 41\n" : "not ok 41\n");
diff --git a/gnu/usr.bin/perl/t/op/my_stash.t b/gnu/usr.bin/perl/t/op/my_stash.t
index 4a1d5022e02..1e93fc7c633 100644
--- a/gnu/usr.bin/perl/t/op/my_stash.t
+++ b/gnu/usr.bin/perl/t/op/my_stash.t
@@ -3,6 +3,7 @@
 package Foo;
 
 BEGIN {
+    chdir 't' if -d 't';
     @INC = '../lib';
 }
 
@@ -14,6 +15,7 @@ use constant MyClass => 'Foo::Bar::Biz::Baz';
 
 {
     package Foo::Bar::Biz::Baz;
+    1;
 }
 
 for (qw(Foo Foo:: MyClass __PACKAGE__)) {
diff --git a/gnu/usr.bin/perl/t/op/numconvert.t b/gnu/usr.bin/perl/t/op/numconvert.t
index f3c9867a911..fedef70d40d 100644
--- a/gnu/usr.bin/perl/t/op/numconvert.t
+++ b/gnu/usr.bin/perl/t/op/numconvert.t
@@ -48,9 +48,11 @@ my $max_chain = $ENV{PERL_TEST_NUMCONVERTS} || 2;
 my $max_uv1 = ~0;
 my $max_uv2 = sprintf "%u", $max_uv1 ** 6; # 6 is an arbitrary number here
 my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here
+my $max_uv_less3 = $max_uv1 - 3;
 
 print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n";
-if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) {
+print "# max_uv_less3 = $max_uv_less3\n";
+if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1 or $max_uv1 == $max_uv_less3) {
   print "1..0 # skipped: unsigned perl arithmetic is not sane";
   eval { require Config; import Config };
   use vars qw(%Config);
@@ -60,6 +62,10 @@ if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) {
   print "\n";
   exit 0;
 }
+if ($max_uv_less3 =~ tr/0-9//c) {
+  print "1..0 # skipped: this perl stringifies large unsigned integers using E notation\n";
+  exit 0;
+}
 
 my $st_t = 4*4;			# We try 4 initializers and 4 reporters
 
@@ -85,8 +91,24 @@ my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1,
 unshift @list, (reverse map -$_, @list), 0; # 15 elts
 @list = map "$_", @list; # Normalize
 
-# print "@list\n";
+print "# @list\n";
+
+# need to special case ++ for max_uv, as ++ "magic" on a string gives
+# another string, whereas ++ magic on a string used as a number gives
+# a number. Not a problem when NV preserves UV, but if it doesn't then
+# stringification of the latter gives something in e notation.
+
+my $max_uv_pp = "$max_uv"; $max_uv_pp++;
+my $max_uv_p1 = "$max_uv"; $max_uv_p1+=0; $max_uv_p1++;
 
+# Also need to cope with %g notation for max_uv_p1 that actually gives an
+# integer less than max_uv because of correct rounding for the limited
+# precisision. This bites for 12 byte long doubles and 8 byte UVs
+
+my $temp = $max_uv_p1;
+my $max_uv_p1_as_iv;
+{use integer; $max_uv_p1_as_iv = 0 + sprintf "%s", $temp}
+my $max_uv_p1_as_uv = 0 | sprintf "%s", $temp;
 
 my @opnames = split //, "-+UINPuinp";
 
@@ -178,12 +200,56 @@ for my $num_chain (1..$max_chain) {
 	    }
 	    push @ans, $inpt;
 	  }
-	  $nok++,
-	    print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n"
-	      if $ans[0] ne $ans[1];
+	  if ($ans[0] ne $ans[1]) {
+	    print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n";
+	    # XXX ought to check that "+" was in the list of opnames
+	    if ((($ans[0] eq $max_uv_pp) and ($ans[1] eq $max_uv_p1))
+		or (($ans[1] eq $max_uv_pp) and ($ans[0] eq $max_uv_p1))) {
+	      # string ++ versus numeric ++. Tolerate this little
+	      # bit of insanity
+	      print "# ok, as string ++ of max_uv is \"$max_uv_pp\", numeric is $max_uv_p1\n"
+	    } elsif ($opnames[$last] eq 'I' and $ans[1] eq "-1"
+		     and $ans[0] eq $max_uv_p1_as_iv) {
+              # Max UV plus 1 is NV. This NV may stringify in E notation.
+              # And the number of decimal digits shown in E notation will depend
+              # on the binary digits in the mantissa. And it may be that
+              # (say)  18446744073709551616 in E notation is truncated to
+              # (say) 1.8446744073709551e+19 (say) which gets converted back
+              # as    1.8446744073709551000e+19
+              # ie    18446744073709551000
+              # which isn't the integer we first had.
+              # But each step of conversion is correct. So it's not an error.
+              # (Only shows up for 64 bit UVs and NVs with 64 bit mantissas,
+              #  and on Crays (64 bit integers, 48 bit mantissas) IIRC)
+	      print "# ok, \"$max_uv_p1\" correctly converts to IV \"$max_uv_p1_as_iv\"\n";
+	    } elsif ($opnames[$last] eq 'U' and $ans[1] eq ~0
+		     and $ans[0] eq $max_uv_p1_as_uv) {
+              # as aboce
+	      print "# ok, \"$max_uv_p1\" correctly converts to UV \"$max_uv_p1_as_uv\"\n";
+	    } elsif (grep {/^N$/} @opnames[@{$curops[0]}]
+		     and $ans[0] == $ans[1] and $ans[0] <= ~0
+                     # First must be in E notation (ie not just digits) and
+                     # second must still be an integer.
+		     # eg 1.84467440737095516e+19
+		     # 1.84467440737095516e+19 for 64 bit mantissa is in the
+		     # integer range, so 1.84467440737095516e+19 + 0 is treated
+		     # as integer addition. [should it be?]
+		     # and 18446744073709551600 + 0 is 18446744073709551600
+		     # Which isn't the string you first thought of.
+                     # I can't remember why there isn't symmetry in this
+                     # exception, ie why only the first ops are tested for 'N'
+                     and $ans[0] != /^-?\d+$/ and $ans[1] !~ /^-?\d+$/) {
+	      print "# ok, numerically equal - notation changed due to adding zero\n";
+	    } else {
+	      $nok++,
+	    }
+	  }
 	}
-	print "not " if $nok;
-	print "ok $test\n";
+        if ($nok) {
+          print "not ok $test\n";
+        } else {
+          print "ok $test\n";
+        }
 	#print $txt if $nok;
 	$test++;
       }
diff --git a/gnu/usr.bin/perl/t/op/or.t b/gnu/usr.bin/perl/t/op/or.t
new file mode 100644
index 00000000000..1f40d61ed5b
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/or.t
@@ -0,0 +1,68 @@
+#!./perl
+
+# Test || in weird situations.
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+
+package Countdown;
+
+sub TIESCALAR {
+  my $class = shift;
+  my $instance = shift || undef;
+  return bless \$instance => $class;
+}
+
+sub FETCH {
+  print "# FETCH!  ${$_[0]}\n";
+  return ${$_[0]}--;
+}
+
+
+package main;
+require './test.pl';
+
+plan( tests => 8 );
+
+
+my ($a, $b, $c);
+
+$! = 1;
+$a = $!;
+my $a_str = sprintf "%s", $a;
+my $a_num = sprintf "%d", $a;
+
+$c = $a || $b;
+
+is($c, $a_str);
+is($c+0, $a_num);   # force numeric context.
+
+$a =~ /./g or die "Match failed for some reason"; # Make $a magic
+
+$c = $a || $b;
+
+is($c, $a_str);
+is($c+0, $a_num);   # force numeric context.
+
+my $val = 3;
+
+$c = $val || $b;
+is($c, 3);
+
+tie $a, 'Countdown', $val;
+
+$c = $a;
+is($c, 3,       'Single FETCH on tied scalar');
+
+$c = $a;
+is($c, 2,       '   $tied = $var');
+
+$c = $a || $b;
+
+{
+    local $TODO = 'Double FETCH';
+    is($c, 1,   '   $tied || $var');
+}
diff --git a/gnu/usr.bin/perl/t/op/override.t b/gnu/usr.bin/perl/t/op/override.t
new file mode 100644
index 00000000000..1a4e5e02f86
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/override.t
@@ -0,0 +1,90 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '.';
+    push @INC, '../lib';
+}
+
+print "1..17\n";
+
+#
+# This file tries to test builtin override using CORE::GLOBAL
+#
+my $dirsep = "/";
+
+BEGIN { package Foo; *main::getlogin = sub { "kilroy"; } }
+
+print "not " unless getlogin eq "kilroy";
+print "ok 1\n";
+
+my $t = 42;
+BEGIN { *CORE::GLOBAL::time = sub () { $t; } }
+
+print "not " unless 45 == time + 3;
+print "ok 2\n";
+
+#
+# require has special behaviour
+#
+my $r;
+BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } }
+
+require Foo;
+print "not " unless $r eq "Foo.pm";
+print "ok 3\n";
+
+require Foo::Bar;
+print "not " unless $r eq join($dirsep, "Foo", "Bar.pm");
+print "ok 4\n";
+
+require 'Foo';
+print "not " unless $r eq "Foo";
+print "ok 5\n";
+
+require 5.6;
+print "not " unless $r eq "5.6";
+print "ok 6\n";
+
+require v5.6;
+print "not " unless abs($r - 5.006) < 0.001 && $r eq "\x05\x06";
+print "ok 7\n";
+
+eval "use Foo";
+print "not " unless $r eq "Foo.pm";
+print "ok 8\n";
+
+eval "use Foo::Bar";
+print "not " unless $r eq join($dirsep, "Foo", "Bar.pm");
+print "ok 9\n";
+
+eval "use 5.6";
+print "not " unless $r eq "5.6";
+print "ok 10\n";
+
+# localizing *CORE::GLOBAL::foo should revert to finding CORE::foo
+{
+    local(*CORE::GLOBAL::require);
+    $r = '';
+    eval "require NoNeXiSt;";
+    print "not " if $r or $@ !~ /^Can't locate NoNeXiSt/i;
+    print "ok 11\n";
+}
+
+#
+# readline() has special behaviour too
+#
+
+$r = 11;
+BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; }
+print <FH>	== 12 ? "ok 12\n" : "not ok 12\n";
+print <$fh>	== 13 ? "ok 13\n" : "not ok 13\n";
+my $pad_fh;
+print <$pad_fh>	== 14 ? "ok 14\n" : "not ok 14\n";
+
+# Non-global readline() override
+BEGIN { *Rgs::readline = sub (;*) { --$r }; }
+package Rgs;
+print <FH>	== 13 ? "ok 15\n" : "not ok 15\n";
+print <$fh>	== 12 ? "ok 16\n" : "not ok 16\n";
+print <$pad_fh>	== 11 ? "ok 17\n" : "not ok 17\n";
diff --git a/gnu/usr.bin/perl/t/op/pow.t b/gnu/usr.bin/perl/t/op/pow.t
new file mode 100644
index 00000000000..2e1d29fcb07
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/pow.t
@@ -0,0 +1,46 @@
+#!./perl -w
+# Now they'll be wanting biff! and zap! tests too.
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+# This calcualtion ought to be within 0.001 of the right answer.
+my $bits_in_uv = int (0.001 + log (~0+1) / log 2);
+
+# 3**30 < 2**48, don't trust things outside that range on a Cray
+# Likewise other 3 should not overflow 48 bits if I did my sums right.
+my @pow = ([3,30,1e-14], [4,32,0], [5,20,1e-14], [2.5, 10,,1e-14], [-2, 69,0]);
+my $tests;
+$tests += $_->[1] foreach @pow;
+
+plan tests => 1 + $bits_in_uv + $tests;
+
+# Ought to be 32, 64, 36 or something like that.
+
+my $remainder = $bits_in_uv & 3;
+
+cmp_ok ($remainder, '==', 0, 'Sanity check bits in UV calculation')
+    or printf "# ~0 is %d (0x%d) which gives $bits_in_uv bits\n", ~0, ~0;
+
+# These are a lot of brute force tests to see how accurate $m ** $n is.
+# Unfortunately rather a lot of perl programs expect 2 ** $n to be integer
+# perfect, forgetting that it's a call to floating point pow() which never
+# claims to deliver perfection.
+foreach my $n (0..$bits_in_uv - 1) {
+    my $exp = 2 ** $n;
+    my $int = 1 << $n;
+    cmp_ok ($exp, '==', $int, "2 ** $n vs 1 << $n");
+}
+
+foreach my $pow (@pow) {
+    my ($base, $max, $range) = @$pow;
+    my $fp = 1;
+    foreach my $n (0..$max-1) {
+        my $exp = $base ** $n;
+        within ($exp, $fp, $range, "$base ** $n [$exp] vs $base * $base * ...");
+        $fp *= $base;
+    }
+}
diff --git a/gnu/usr.bin/perl/t/op/pwent.t b/gnu/usr.bin/perl/t/op/pwent.t
index d811f06a33e..4d9de4490f1 100644
--- a/gnu/usr.bin/perl/t/op/pwent.t
+++ b/gnu/usr.bin/perl/t/op/pwent.t
@@ -3,7 +3,7 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
-    eval {my @n = getpwuid 0};
+    eval {my @n = getpwuid 0; setpwent()};
     if ($@ && $@ =~ /(The \w+ function is unimplemented)/) {
 	print "1..0 # Skip: $1\n";
 	exit 0;
@@ -49,6 +49,18 @@ BEGIN {
 	}
     }
 
+    if (not defined $where) {      # Try NIS+
+     foreach my $niscat (qw(/bin/niscat)) {
+         if (-x $niscat &&
+           open(PW, "$niscat passwd.org_dir 2>/dev/null |") &&
+           defined(<PW>)) {
+           $where = "NIS+ $niscat passwd.org_dir";
+           undef $reason;
+           last;
+         }
+     }
+    }
+
     if ($reason) {	# Give up.
 	print "1..0 # Skip: $reason\n";
 	exit 0;
@@ -68,7 +80,10 @@ my $tst = 1;
 my %perfect;
 my %seen;
 
+print "# where $where\n";
+
 setpwent();
+
 while (<PW>) {
     chomp;
     # LIMIT -1 so that users with empty shells don't fall off
@@ -115,9 +130,12 @@ while (<PW>) {
     }
     $n++;
 }
+
 endpwent();
 
-if (keys %perfect == 0) {
+print "# max = $max, n = $n, perfect = ", scalar keys %perfect, "\n";
+
+if (keys %perfect == 0 && $n) {
     $max++;
     print <<EOEX;
 #
diff --git a/gnu/usr.bin/perl/t/op/qq.t b/gnu/usr.bin/perl/t/op/qq.t
new file mode 100644
index 00000000000..d8831696a79
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/qq.t
@@ -0,0 +1,63 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+print q(1..21
+);
+
+# This is() function is written to avoid ""
+my $test = 1;
+sub is {
+    my($left, $right) = @_;
+
+    if ($left eq $right) {
+      printf 'ok %d
+', $test++;
+      return 1;
+    }
+    foreach ($left, $right) {
+      # Comment out these regexps to map non-printables to ord if the perl under
+      # test is so broken that it's not helping
+      s/([^-+A-Za-z_0-9])/sprintf q{'.chr(%d).'}, ord $1/ge;
+      $_ = sprintf q('%s'), $_;
+      s/^''\.//;
+      s/\.''$//;
+    }
+    printf q(not ok %d - got %s expected %s
+), $test++, $left, $right;
+
+    printf q(# Failed test at line %d
+), (caller)[2];
+
+    return 0;
+}
+
+is ("\x53", chr 83);
+is ("\x4EE", chr (78) . 'E');
+is ("\x4i", chr (4) . 'i');	# This will warn
+is ("\xh", chr (0) . 'h');	# This will warn
+is ("\xx", chr (0) . 'x');	# This will warn
+is ("\xx9", chr (0) . 'x9');	# This will warn. \x9 is tab in EBCDIC too?
+is ("\x9_E", chr (9) . '_E');	# This will warn
+
+is ("\x{4E}", chr 78);
+is ("\x{6_9}", chr 105);
+is ("\x{_6_3}", chr 99);
+is ("\x{_6B}", chr 107);
+
+is ("\x{9__0}", chr 9);		# multiple underscores not allowed.
+is ("\x{77_}", chr 119);	# trailing underscore warns.
+is ("\x{6FQ}z", chr (111) . 'z');
+
+is ("\x{0x4E}", chr 0);
+is ("\x{x4E}", chr 0);
+
+is ("\x{0065}", chr 101);
+is ("\x{000000000000000000000000000000000000000000000000000000000000000072}",
+    chr 114);
+is ("\x{0_06_5}", chr 101);
+is ("\x{1234}", chr 4660);
+is ("\x{10FFFD}", chr 1114109);
diff --git a/gnu/usr.bin/perl/t/op/splice.t b/gnu/usr.bin/perl/t/op/splice.t
index 06e350988d0..6d9b71f0647 100644
--- a/gnu/usr.bin/perl/t/op/splice.t
+++ b/gnu/usr.bin/perl/t/op/splice.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..9\n";
+print "1..12\n";
 
 @a = (1..10);
 
@@ -21,7 +21,7 @@ print "ok 4\n";
 print "not " unless j(splice(@a,5,1,5)) eq "5" && j(@a) eq j(0..11);
 print "ok 5\n";
 
-print "not " unless j(splice(@a, 20, 0, 12, 13)) eq "" && j(@a) eq j(0..13);
+print "not " unless j(splice(@a, @a, 0, 12, 13)) eq "" && j(@a) eq j(0..13);
 print "ok 6\n";
 
 print "not " unless j(splice(@a, -@a, @a, 1, 2, 3)) eq j(0..13) && j(@a) eq j(1..3);
@@ -32,3 +32,23 @@ print "ok 8\n";
 
 print "not " unless j(splice(@a,-3,-2,2)) eq j(7) && j(@a) eq j(1,2,7,3);
 print "ok 9\n";
+
+# Bug 20000223.001 - no test for splice(@array).  Destructive test!
+print "not " unless j(splice(@a)) eq j(1,2,7,3) && j(@a) eq '';
+print "ok 10\n";
+
+# Tests 11 and 12:
+# [ID 20010711.005] in Tie::Array, SPLICE ignores context, breaking SHIFT
+
+my $foo;
+
+@a = ('red', 'green', 'blue');
+$foo = splice @a, 1, 2;
+print "not " unless $foo eq 'blue';
+print "ok 11\n";
+
+@a = ('red', 'green', 'blue');
+$foo = shift @a;
+print "not " unless $foo eq 'red';
+print "ok 12\n";
+
diff --git a/gnu/usr.bin/perl/t/op/srand.t b/gnu/usr.bin/perl/t/op/srand.t
new file mode 100644
index 00000000000..5753a5d0eb8
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/srand.t
@@ -0,0 +1,59 @@
+#!./perl -w
+
+BEGIN {
+    chdir "t" if -d "t";
+    @INC = qw(. ../lib);
+}
+
+# Test srand.
+
+use strict;
+
+require "test.pl";
+plan(tests => 4);
+
+# Generate a load of random numbers.
+# int() avoids possible floating point error.
+sub mk_rand { map int rand 10000, 1..100; }
+
+
+# Check that rand() is deterministic.
+srand(1138);
+my @first_run  = mk_rand;
+
+srand(1138);
+my @second_run = mk_rand;
+
+ok( eq_array(\@first_run, \@second_run),  'srand(), same arg, same rands' );
+
+
+# Check that different seeds provide different random numbers
+srand(31337);
+@first_run  = mk_rand;
+
+srand(1138);
+@second_run = mk_rand;
+
+ok( !eq_array(\@first_run, \@second_run),
+                                 'srand(), different arg, different rands' );
+
+
+# Check that srand() isn't affected by $_
+{   
+    local $_ = 42;
+    srand();
+    @first_run  = mk_rand;
+
+    srand(42);
+    @second_run = mk_rand;
+
+    ok( !eq_array(\@first_run, \@second_run),
+                       'srand(), no arg, not affected by $_');
+}
+
+# This test checks whether Perl called srand for you.
+@first_run  = `$^X -le "print int rand 100 for 1..100"`;
+sleep(1); # in case our srand() is too time-dependent
+@second_run = `$^X -le "print int rand 100 for 1..100"`;
+
+ok( !eq_array(\@first_run, \@second_run), 'srand() called automatically');
diff --git a/gnu/usr.bin/perl/t/op/sub_lval.t b/gnu/usr.bin/perl/t/op/sub_lval.t
new file mode 100644
index 00000000000..308269eee93
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/sub_lval.t
@@ -0,0 +1,565 @@
+print "1..67\n";
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+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.
+print "ok 1\n";
+
+my @out = grep /main/, a(b()); # Check that temporaries are allowed.
+print "# `@out'\nnot " unless @out==1; # Not reached if error.
+print "ok 2\n";
+
+my $in;
+
+# Check that we can return localized values from subroutines:
+
+sub in : lvalue { $in = shift; }
+sub neg : lvalue {  #(num_str) return num_str
+    local $_ = shift;
+    s/^\+/-/;
+    $_;
+}
+in(neg("+2"));
+
+
+print "# `$in'\nnot " unless $in eq '-2';
+print "ok 3\n";
+
+sub get_lex : lvalue { $in }
+sub get_st : lvalue { $blah }
+sub id : lvalue { ${\shift} }
+sub id1 : lvalue { $_[0] }
+sub inc : lvalue { ${\++$_[0]} }
+
+$in = 5;
+$blah = 3;
+
+get_st = 7;
+
+print "# `$blah' ne 7\nnot " unless $blah == 7;
+print "ok 4\n";
+
+get_lex = 7;
+
+print "# `$in' ne 7\nnot " unless $in == 7;
+print "ok 5\n";
+
+++get_st;
+
+print "# `$blah' ne 8\nnot " unless $blah == 8;
+print "ok 6\n";
+
+++get_lex;
+
+print "# `$in' ne 8\nnot " unless $in == 8;
+print "ok 7\n";
+
+id(get_st) = 10;
+
+print "# `$blah' ne 10\nnot " unless $blah == 10;
+print "ok 8\n";
+
+id(get_lex) = 10;
+
+print "# `$in' ne 10\nnot " unless $in == 10;
+print "ok 9\n";
+
+++id(get_st);
+
+print "# `$blah' ne 11\nnot " unless $blah == 11;
+print "ok 10\n";
+
+++id(get_lex);
+
+print "# `$in' ne 11\nnot " unless $in == 11;
+print "ok 11\n";
+
+id1(get_st) = 20;
+
+print "# `$blah' ne 20\nnot " unless $blah == 20;
+print "ok 12\n";
+
+id1(get_lex) = 20;
+
+print "# `$in' ne 20\nnot " unless $in == 20;
+print "ok 13\n";
+
+++id1(get_st);
+
+print "# `$blah' ne 21\nnot " unless $blah == 21;
+print "ok 14\n";
+
+++id1(get_lex);
+
+print "# `$in' ne 21\nnot " unless $in == 21;
+print "ok 15\n";
+
+inc(get_st);
+
+print "# `$blah' ne 22\nnot " unless $blah == 22;
+print "ok 16\n";
+
+inc(get_lex);
+
+print "# `$in' ne 22\nnot " unless $in == 22;
+print "ok 17\n";
+
+inc(id(get_st));
+
+print "# `$blah' ne 23\nnot " unless $blah == 23;
+print "ok 18\n";
+
+inc(id(get_lex));
+
+print "# `$in' ne 23\nnot " unless $in == 23;
+print "ok 19\n";
+
+++inc(id1(id(get_st)));
+
+print "# `$blah' ne 25\nnot " unless $blah == 25;
+print "ok 20\n";
+
+++inc(id1(id(get_lex)));
+
+print "# `$in' ne 25\nnot " unless $in == 25;
+print "ok 21\n";
+
+@a = (1) x 3;
+@b = (undef) x 2;
+$#c = 3;			# These slots are not fillable.
+
+# Explanation: empty slots contain &sv_undef.
+
+=for disabled constructs
+
+sub a3 :lvalue {@a}
+sub b2 : lvalue {@b}
+sub c4: lvalue {@c}
+
+$_ = '';
+
+eval <<'EOE' or $_ = $@;
+  ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78);
+  1;
+EOE
+
+#@out = ($x, a3, $y, b2, $z, c4, $t);
+#@in = (34 .. 41, (undef) x 4, 46);
+#print "# `@out' ne `@in'\nnot " unless "@out" eq "@in";
+
+print "# '$_'.\nnot "
+  unless /Can\'t return an uninitialized value from lvalue subroutine/;
+=cut
+
+print "ok 22\n";
+
+my $var;
+
+sub a::var : lvalue { $var }
+
+"a"->var = 45;
+
+print "# `$var' ne 45\nnot " unless $var == 45;
+print "ok 23\n";
+
+my $oo;
+$o = bless \$oo, "a";
+
+$o->var = 47;
+
+print "# `$var' ne 47\nnot " unless $var == 47;
+print "ok 24\n";
+
+sub o : lvalue { $o }
+
+o->var = 49;
+
+print "# `$var' ne 49\nnot " unless $var == 49;
+print "ok 25\n";
+
+sub nolv () { $x0, $x1 } # Not lvalue
+
+$_ = '';
+
+eval <<'EOE' or $_ = $@;
+  nolv = (2,3);
+  1;
+EOE
+
+print "not "
+  unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
+print "ok 26\n";
+
+$_ = '';
+
+eval <<'EOE' or $_ = $@;
+  nolv = (2,3) if $_;
+  1;
+EOE
+
+print "not "
+  unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
+print "ok 27\n";
+
+$_ = '';
+
+eval <<'EOE' or $_ = $@;
+  &nolv = (2,3) if $_;
+  1;
+EOE
+
+print "not "
+  unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
+print "ok 28\n";
+
+$x0 = $x1 = $_ = undef;
+$nolv = \&nolv;
+
+eval <<'EOE' or $_ = $@;
+  $nolv->() = (2,3) if $_;
+  1;
+EOE
+
+print "# '$_', '$x0', '$x1'.\nnot " if defined $_;
+print "ok 29\n";
+
+$x0 = $x1 = $_ = undef;
+$nolv = \&nolv;
+
+eval <<'EOE' or $_ = $@;
+  $nolv->() = (2,3);
+  1;
+EOE
+
+print "# '$_', '$x0', '$x1'.\nnot "
+  unless /Can\'t modify non-lvalue subroutine call/;
+print "ok 30\n";
+
+sub lv0 : lvalue { }		# Converted to lv10 in scalar context
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  lv0 = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Empty array returned from lvalue subroutine in scalar context/;
+print "ok 31\n";
+
+sub lv10 : lvalue {}
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  (lv0) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot " if defined $_;
+print "ok 32\n";
+
+sub lv1u :lvalue { undef }
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  lv1u = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return a readonly value from lvalue subroutine/;
+print "ok 33\n";
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  (lv1u) = (2,3);
+  1;
+EOE
+
+# Fixed by change @10777
+#print "# '$_'.\nnot "
+#  unless /Can\'t return an uninitialized value from lvalue subroutine/;
+print "ok 34 # Skip: removed test\n";
+
+$x = '1234567';
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  sub lv1t : lvalue { index $x, 2 }
+  lv1t = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t modify index in lvalue subroutine return/;
+print "ok 35\n";
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  sub lv2t : lvalue { shift }
+  (lv2t) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t modify shift in lvalue subroutine return/;
+print "ok 36\n";
+
+$xxx = 'xxx';
+sub xxx () { $xxx }  # Not lvalue
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  sub lv1tmp : lvalue { xxx }			# is it a TEMP?
+  lv1tmp = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/;
+print "ok 37\n";
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  (lv1tmp) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return a temporary from lvalue subroutine/;
+print "ok 38\n";
+
+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 modify constant item in lvalue subroutine return/;
+print "ok 39\n";
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  (lv1tmpr) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return a readonly value from lvalue subroutine/;
+print "ok 40\n";
+
+sub lva : lvalue {@a}
+
+$_ = undef;
+@a = ();
+$a[1] = 12;
+eval <<'EOE' or $_ = $@;
+  (lva) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
+print "ok 41\n";
+
+$_ = undef;
+@a = ();
+$a[0] = undef;
+$a[1] = 12;
+eval <<'EOE' or $_ = $@;
+  (lva) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
+print "ok 42\n";
+
+$_ = undef;
+@a = ();
+$a[0] = undef;
+$a[1] = 12;
+eval <<'EOE' or $_ = $@;
+  (lva) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
+print "ok 43\n";
+
+sub lv1n : lvalue { $newvar }
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  lv1n = (3,4);
+  1;
+EOE
+
+print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' ";
+print "ok 44\n";
+
+sub lv1nn : lvalue { $nnewvar }
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  (lv1nn) = (3,4);
+  1;
+EOE
+
+print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' ";
+print "ok 45\n";
+
+$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";
+
+print "ok 48 # Skip: removed test\n";
+
+print "ok 49 # Skip: removed test\n";
+
+{
+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";
+
+require './test.pl';
+curr_test(65);
+
+TODO: {
+    local $TODO = 'test explicit return of lval expr';
+
+    # subs are corrupted copies from tests 1-~4
+    sub bad_get_lex : lvalue { return $in };
+    sub bad_get_st  : lvalue { return $blah }
+
+    sub bad_id  : lvalue { return ${\shift} }
+    sub bad_id1 : lvalue { return $_[0] }
+    sub bad_inc : lvalue { return ${\++$_[0]} }
+
+    $in = 5;
+    $blah = 3;
+
+    bad_get_st = 7;
+
+    is( $blah, 7 );
+
+    bad_get_lex = 7;
+
+    is($in, 7, "yada");
+
+    ++bad_get_st;
+
+    is($blah, 8, "yada");
+}
+
diff --git a/gnu/usr.bin/perl/t/op/tiearray.t b/gnu/usr.bin/perl/t/op/tiearray.t
index 8e78b2f76b0..337aff689af 100644
--- a/gnu/usr.bin/perl/t/op/tiearray.t
+++ b/gnu/usr.bin/perl/t/op/tiearray.t
@@ -101,7 +101,7 @@ sub SPLICE
 
 package main;
 
-print "1..31\n";                   
+print "1..36\n";                   
 my $test = 1;
 
 {my @ary;
@@ -187,6 +187,7 @@ print "ok ", $test++,"\n";
 @ary = split(/:/,'1:2:3');
 print "not " unless join(':',@ary) eq '1:2:3';
 print "ok ", $test++,"\n";         
+
   
 my $t = 0;
 foreach $n (@ary)
@@ -195,6 +196,25 @@ foreach $n (@ary)
   print "ok ", $test++,"\n";         
  }
 
+# (30-33) 20020303 mjd-perl-patch+@plover.com
+@ary = ();
+$seen{POP} = 0;
+pop @ary;                       # this didn't used to call POP at all
+print "not " unless $seen{POP} == 1;
+print "ok ", $test++,"\n";         
+$seen{SHIFT} = 0;
+shift @ary;                     # this didn't used to call SHIFT at  all
+print "not " unless $seen{SHIFT} == 1;
+print "ok ", $test++,"\n";         
+$seen{PUSH} = 0;
+push @ary;                       # this didn't used to call PUSH at all
+print "not " unless $seen{PUSH} == 1;
+print "ok ", $test++,"\n";         
+$seen{UNSHIFT} = 0;
+unshift @ary;                   # this didn't used to call UNSHIFT at all
+print "not " unless $seen{UNSHIFT} == 1;
+print "ok ", $test++,"\n";         
+
 @ary = qw(3 2 1);
 print "not " unless join(':',@ary) eq '3:2:1';
 print "ok ", $test++,"\n";         
@@ -202,9 +222,25 @@ print "ok ", $test++,"\n";
 untie @ary;   
 
 }
+
+# 20020401 mjd-perl-patch+@plover.com
+# Thanks to Dave Mitchell for the small test case and the fix
+{
+  my @a;
+  
+  sub X::TIEARRAY { bless {}, 'X' }
+
+  sub X::SPLICE {
+    do '/dev/null';
+    die;
+  }
+
+  tie @a, 'X';
+  eval { splice(@a) };
+  # If we survived this far.
+  print "ok ", $test++, "\n";
+}
                            
 print "not " unless $seen{'DESTROY'} == 2;
 print "ok ", $test++,"\n";         
 
-
-
diff --git a/gnu/usr.bin/perl/t/op/tiehandle.t b/gnu/usr.bin/perl/t/op/tiehandle.t
index b04bdb78977..257a6139587 100644
--- a/gnu/usr.bin/perl/t/op/tiehandle.t
+++ b/gnu/usr.bin/perl/t/op/tiehandle.t
@@ -77,7 +77,7 @@ package main;
 
 use Symbol;
 
-print "1..33\n";
+print "1..39\n";
 
 my $fh = gensym;
 
@@ -160,8 +160,73 @@ ok($r == 1);
     use warnings;
     # Special case of aliasing STDERR, which used
     # to dump core when warnings were enabled
-    *STDERR = *$fh;
+    local *STDERR = *$fh;
     @expect = (PRINT => $ob,"some","text");
     $r = print STDERR @expect[2,3];
     ok($r == 1);
 }
+
+{
+    # Test for change #11536
+    package Foo;
+    use strict;
+    sub TIEHANDLE { bless {} }
+    my $cnt = 'a';
+    sub READ {
+	$_[1] = $cnt++;
+	1;
+    }
+    sub do_read {
+	my $fh = shift;
+	read $fh, my $buff, 1;
+	main::ok(1);
+    }
+    $|=1;
+    tie *STDIN, 'Foo';
+    read STDIN, my $buff, 1;
+    main::ok(1);
+    do_read(\*STDIN);
+    untie *STDIN;
+}
+
+
+{
+    # test for change 11639: Can't localize *FH, then tie it
+    {
+	local *foo;
+	tie %foo, 'Blah';
+    }
+    ok(!tied %foo);
+
+    {
+	local *bar;
+	tie @bar, 'Blah';
+    }
+    ok(!tied @bar);
+
+    {
+	local *BAZ;
+	tie *BAZ, 'Blah';
+    }
+    ok(!tied *BAZ);
+
+    package Blah;
+
+    sub TIEHANDLE {bless {}}
+    sub TIEHASH   {bless {}}
+    sub TIEARRAY  {bless {}}
+}
+
+{
+    # warnings should pass to the PRINT method of tied STDERR
+    my @received;
+
+    local *STDERR = *$fh;
+    local *Implement::PRINT = sub { @received = @_ };
+
+    $r = warn("some", "text", "\n");
+    @expect = (PRINT => $ob,"sometext\n");
+
+    Implement::compare(PRINT => @received);
+}
+
diff --git a/gnu/usr.bin/perl/t/op/tr.t b/gnu/usr.bin/perl/t/op/tr.t
index c7ba0d8c55f..b37eb7f1861 100644
--- a/gnu/usr.bin/perl/t/op/tr.t
+++ b/gnu/usr.bin/perl/t/op/tr.t
@@ -3,26 +3,26 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
+    require './test.pl';
 }
 
-print "1..54\n";
+plan tests => 97;
+
+my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1);
 
 $_ = "abcdefghijklmnopqrstuvwxyz";
 
 tr/a-z/A-Z/;
 
-print "not " unless $_ eq "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
-print "ok 1\n";
+is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ",    'uc');
 
 tr/A-Z/a-z/;
 
-print "not " unless $_ eq "abcdefghijklmnopqrstuvwxyz";
-print "ok 2\n";
+is($_, "abcdefghijklmnopqrstuvwxyz",    'lc');
 
 tr/b-y/B-Y/;
+is($_, "aBCDEFGHIJKLMNOPQRSTUVWXYz",    'partial uc');
 
-print "not " unless $_ eq "aBCDEFGHIJKLMNOPQRSTUVWXYz";
-print "ok 3\n";
 
 # In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91.
 # Yes, discontinuities.  Regardless, the \xca in the below should stay
@@ -33,153 +33,154 @@ print "ok 3\n";
 
     tr/I-J/i-j/;
 
-    print "not " unless $_ eq "i\xcaj";
-    print "ok 4\n";
+    is($_, "i\xcaj",    'EBCDIC discontinuity');
 }
 #
 
-# make sure that tr cancels IOK and NOK
+
 ($x = 12) =~ tr/1/3/;
 (my $y = 12) =~ tr/1/3/;
 ($f = 1.5) =~ tr/1/3/;
 (my $g = 1.5) =~ tr/1/3/;
-print "not " unless $x + $y + $f + $g == 71;
-print "ok 5\n";
+is($x + $y + $f + $g, 71,   'tr cancels IOK and NOK');
 
-# make sure tr is harmless if not updating  -  see [ID 20000511.005]
+
+# perlbug [ID 20000511.005]
 $_ = 'fred';
 /([a-z]{2})/;
 $1 =~ tr/A-Z//;
 s/^(\s*)f/$1F/;
-print "not " if $_ ne 'Fred';
-print "ok 6\n";
+is($_, 'Fred',  'harmless if explicitly not updating');
+
+
+# A variant of the above, added in 5.7.2
+$_ = 'fred';
+/([a-z]{2})/;
+eval '$1 =~ tr/A-Z/A-Z/;';
+s/^(\s*)f/$1F/;
+is($_, 'Fred',  'harmless if implicitly not updating');
+is($@, '',      '    no error');
+
 
 # check tr handles UTF8 correctly
 ($x = 256.65.258) =~ tr/a/b/;
-print "not " if $x ne 256.65.258 or length $x != 3;
-print "ok 7\n";
+is($x, 256.65.258,  'handles UTF8');
+is(length $x, 3);
+
 $x =~ tr/A/B/;
+is(length $x, 3);
 if (ord("\t") == 9) { # ASCII
-    print "not " if $x ne 256.66.258 or length $x != 3;
+    is($x, 256.66.258);
 }
 else {
-    print "not " if $x ne 256.65.258 or length $x != 3;
+    is($x, 256.65.258);
 }
-print "ok 8\n";
+
 # EBCDIC variants of the above tests
 ($x = 256.193.258) =~ tr/a/b/;
-print "not " if $x ne 256.193.258 or length $x != 3;
-print "ok 9\n";
+is(length $x, 3);
+is($x, 256.193.258);
+
 $x =~ tr/A/B/;
+is(length $x, 3);
 if (ord("\t") == 9) { # ASCII
-    print "not " if $x ne 256.193.258 or length $x != 3;
+    is($x, 256.193.258);
 }
 else {
-    print "not " if $x ne 256.194.258 or length $x != 3;
+    is($x, 256.194.258);
 }
-print "ok 10\n";
+
 
 {
-if (ord("\t") == 9) { # ASCII
-    use utf8;
-}
-# 11 - changing UTF8 characters in a UTF8 string, same length.
-$l = chr(300); $r = chr(400);
-$x = 200.300.400;
-$x =~ tr/\x{12c}/\x{190}/;
-printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3;
-print "ok 11\n";
-
-# 12 - changing UTF8 characters in UTF8 string, more bytes.
-$x = 200.300.400;
-$x =~ tr/\x{12c}/\x{be8}/;
-printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3;
-print "ok 12\n";
-
-# 13 - introducing UTF8 characters to non-UTF8 string.
-$x = 100.125.60;
-$x =~ tr/\x{64}/\x{190}/;
-printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3;
-print "ok 13\n";
-
-# 14 - removing UTF8 characters from UTF8 string
-$x = 400.125.60;
-$x =~ tr/\x{190}/\x{64}/;
-printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3;
-print "ok 14\n";
-
-# 15 - counting UTF8 chars in UTF8 string
-$x = 400.125.60.400;
-$y = $x =~ tr/\x{190}/\x{190}/;
-print "not " if $y != 2;
-print "ok 15\n";
-
-# 16 - counting non-UTF8 chars in UTF8 string
-$x = 60.400.125.60.400;
-$y = $x =~ tr/\x{3c}/\x{3c}/;
-print "not " if $y != 2;
-print "ok 16\n";
-
-# 17 - counting UTF8 chars in non-UTF8 string
-$x = 200.125.60;
-$y = $x =~ tr/\x{190}/\x{190}/;
-print "not " if $y != 0;
-print "ok 17\n";
+    my $l = chr(300); my $r = chr(400);
+    $x = 200.300.400;
+    $x =~ tr/\x{12c}/\x{190}/;
+    is($x, 200.400.400,     
+                        'changing UTF8 chars in a UTF8 string, same length');
+    is(length $x, 3);
+
+    $x = 200.300.400;
+    $x =~ tr/\x{12c}/\x{be8}/;
+    is($x, 200.3048.400,    '    more bytes');
+    is(length $x, 3);
+
+    $x = 100.125.60;
+    $x =~ tr/\x{64}/\x{190}/;
+    is($x, 400.125.60,      'Putting UT8 chars into a non-UTF8 string');
+    is(length $x, 3);
+
+    $x = 400.125.60;
+    $x =~ tr/\x{190}/\x{64}/;
+    is($x, 100.125.60,      'Removing UTF8 chars from UTF8 string');
+    is(length $x, 3);
+
+    $x = 400.125.60.400;
+    $y = $x =~ tr/\x{190}/\x{190}/;
+    is($y, 2,               'Counting UTF8 chars in UTF8 string');
+
+    $x = 60.400.125.60.400;
+    $y = $x =~ tr/\x{3c}/\x{3c}/;
+    is($y, 2,               '         non-UTF8 chars in UTF8 string');
+
+    # 17 - counting UTF8 chars in non-UTF8 string
+    $x = 200.125.60;
+    $y = $x =~ tr/\x{190}/\x{190}/;
+    is($y, 0,               '         UTF8 chars in non-UTFs string');
 }
 
-# 18: test brokenness with tr/a-z-9//;
 $_ = "abcdefghijklmnopqrstuvwxyz";
-eval "tr/a-z-9/ /";
-print (($@ =~ /^Ambiguous range in transliteration operator/ || $^V lt v5.7.0) 
-       ? '' : 'not ', "ok 18\n");
+eval 'tr/a-z-9/ /';
+like($@, qr/^Ambiguous range in transliteration operator/,  'tr/a-z-9//');
 
 # 19-21: Make sure leading and trailing hyphens still work
 $_ = "car-rot9";
 tr/-a-m/./;
-print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n");
+is($_, '..r.rot9',  'hyphens, leading');
 
 $_ = "car-rot9";
 tr/a-m-/./;
-print (($_ eq '..r.rot9') ? '' : 'not ', "ok 20\n");
+is($_, '..r.rot9',  '   trailing');
 
 $_ = "car-rot9";
 tr/-a-m-/./;
-print (($_ eq '..r.rot9') ? '' : 'not ', "ok 21\n");
+is($_, '..r.rot9',  '   both');
 
 $_ = "abcdefghijklmnop";
 tr/ae-hn/./;
-print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 22\n");
+is($_, '.bcd....ijklm.op');
 
 $_ = "abcdefghijklmnop";
 tr/a-cf-kn-p/./;
-print (($_ eq '...de......lm...') ? '' : 'not ', "ok 23\n");
+is($_, '...de......lm...');
 
 $_ = "abcdefghijklmnop";
 tr/a-ceg-ikm-o/./;
-print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 24\n");
+is($_, '...d.f...j.l...p');
+
 
-# 25: Test reversed range check
 # 20000705 MJD
 eval "tr/m-d/ /";
-print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/ || $^V lt v5.7.0) 
-       ? '' : 'not ', "ok 25\n");
+like($@, qr/^Invalid \[\] range "m-d" in transliteration operator/,
+              'reversed range check');
 
-# 26: test cannot update if read-only
 eval '$1 =~ tr/x/y/';
-print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ',
-       "ok 26\n");
+like($@, qr/^Modification of a read-only value attempted/,
+              'cannot update read-only var');
+
+'abcdef' =~ /(bcd)/;
+is(eval '$1 =~ tr/abcd//', 3,  'explicit read-only count');
+is($@, '',                      '    no error');
 
-# 27: test can count read-only
 'abcdef' =~ /(bcd)/;
-print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 27\n");
+is(eval '$1 =~ tr/abcd/abcd/', 3,  'implicit read-only count');
+is($@, '',                      '    no error');
 
-# 28: test lhs OK if not updating
-print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 28\n");
+is(eval '"123" =~ tr/12//', 2,     'LHS of non-updating tr');
+
+eval '"123" =~ tr/1/2/';
+like($@, qr|^Can't modify constant item in transliteration \(tr///\)|,
+         'LHS bad on updating tr');
 
-# 29: test lhs bad if updating
-eval '"123" =~ tr/1/1/';
-print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|)
-       ? '' : 'not ', "ok 29\n");
 
 # v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac)
 # v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90)
@@ -187,125 +188,194 @@ print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|)
 # Transliterate a byte to a byte, all four ways.
 
 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/;
-print "not " unless $a eq v300.197.172.300.197.172;
-print "ok 30\n";
+is($a, v300.197.172.300.197.172,    'byte2byte transliteration');
 
 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
-print "not " unless $a eq v300.197.172.300.197.172;
-print "ok 31\n";
+is($a, v300.197.172.300.197.172);
 
 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
-print "not " unless $a eq v300.197.172.300.197.172;
-print "ok 32\n";
+is($a, v300.197.172.300.197.172);
 
 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
-print "not " unless $a eq v300.197.172.300.197.172;
-print "ok 33\n";
+is($a, v300.197.172.300.197.172);
 
-# Transliterate a byte to a wide character.
 
 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
-print "not " unless $a eq v300.301.172.300.301.172;
-print "ok 34\n";
-
-# Transliterate a wide character to a byte.
+is($a, v300.301.172.300.301.172,    'byte2wide transliteration');
 
 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
-print "not " unless $a eq v195.196.172.195.196.172;
-print "ok 35\n";
-
-# Transliterate a wide character to a wide character.
+is($a, v195.196.172.195.196.172,    '   wide2byte');
 
 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
-print "not " unless $a eq v301.196.172.301.196.172;
-print "ok 36\n";
+is($a, v301.196.172.301.196.172,    '   wide2wide');
 
-# Transliterate both ways.
 
 ($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/;
-print "not " unless $a eq v195.301.172.195.301.172;
-print "ok 37\n";
+is($a, v195.301.172.195.301.172,    'byte2wide & wide2byte');
 
-# Transliterate all (four) ways.
 
 ($a = v300.196.172.300.196.172.400.198.144) =~
 	tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/;
-print "not " unless $a eq v197.301.173.197.301.173.401.198.144;
-print "ok 38\n";
+is($a, v197.301.173.197.301.173.401.198.144,    'all together now!');
 
-# Transliterate and count.
 
-print "not "
-    unless (($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/)       == 2;
-print "ok 39\n";
+is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2,
+                                     'transliterate and count');
 
-print "not "
-    unless (($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/) == 2;
-print "ok 40\n";
+is((($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/), 2);
 
-# Transliterate with complement.
 
 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c;
-print "not " unless $a eq v301.196.301.301.196.301;
-print "ok 41\n";
+is($a, v301.196.301.301.196.301,    'translit w/complement');
 
 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
-print "not " unless $a eq v300.197.197.300.197.197;
-print "ok 42\n";
+is($a, v300.197.197.300.197.197);
 
-# Transliterate with deletion.
 
 ($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
-print "not " unless $a eq v300.172.300.172;
-print "ok 43\n";
+is($a, v300.172.300.172,            'translit w/deletion');
 
 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
-print "not " unless $a eq v196.172.196.172;
-print "ok 44\n";
+is($a, v196.172.196.172);
 
-# Transliterate with squeeze.
 
 ($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
-print "not " unless $a eq v197.172.300.300.197.172;
-print "ok 45\n";
+is($a, v197.172.300.300.197.172,    'translit w/squeeze');
 
 ($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s;
-print "not " unless $a eq v196.172.301.196.172.172;
-print "ok 46\n";
+is($a, v196.172.301.196.172.172);
 
-# Tricky cases by Simon Cozens.
 
+# Tricky cases (When Simon Cozens Attacks)
 ($a = v196.172.200) =~ tr/\x{12c}/a/;
-print "not " unless sprintf("%vd", $a) eq '196.172.200';
-print "ok 47\n";
+is(sprintf("%vd", $a), '196.172.200');
 
 ($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
-print "not " unless sprintf("%vd", $a) eq '196.172.200';
-print "ok 48\n";
+is(sprintf("%vd", $a), '196.172.200');
 
 ($a = v196.172.200) =~ tr/\x{12c}//d;
-print "not " unless sprintf("%vd", $a) eq '196.172.200';
-print "ok 49\n";
+is(sprintf("%vd", $a), '196.172.200');
 
-# UTF8 range
 
+# UTF8 range tests from Inaba Hiroto
+
+# Not working in EBCDIC as of 12674.
 ($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
-print "not " unless $a eq v192.196.172.194.197.172;
-print "ok 50\n";
+is($a, v192.196.172.194.197.172,    'UTF range');
 
 ($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/;
-print "not " unless $a eq v300.300.172.302.301.172;
-print "ok 51\n";
+is($a, v300.300.172.302.301.172);
+
+
+# UTF8 range tests from Karsten Sperling (patch #9008 required)
+
+($a = "\x{0100}") =~ tr/\x00-\x{100}/X/;
+is($a, "X");
+
+($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c;
+is($a, "X");
+
+($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
+is($a, "X");
+ 
+($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
+is($a, "X");
+
 
-# misc
+# UTF8 range tests from Inaba Hiroto
+
+($a = "\x{200}") =~ tr/\x00-\x{100}/X/c;
+is($a, "X");
+
+($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs;
+is($a, "X");
+
+
+# Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters,
+# (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
+# from Karsten Sperling.
+
+# Not working in EBCDIC as of 12674.
+$c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
+is($c, 8);
+is($a, "XXXXXXXX");
+   
+# Not working in EBCDIC as of 12674.
+$c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
+is($c, 8);
+is($a, "XXXXXXXX");
+
+
+SKIP: {   
+    skip "not EBCDIC", 4 unless $Is_EBCDIC;
+
+    $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
+    is($c, 2);
+    is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X");
+   
+    $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
+    is($c, 2);
+    is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X");
+}
+
+($a = "\x{100}") =~ tr/\x00-\xff/X/c;
+is(ord($a), ord("X"));
+
+($a = "\x{100}") =~ tr/\x00-\xff/X/cs;
+is(ord($a), ord("X"));
+
+($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c;
+is($a, "\x{100}\x{100}");
+
+($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs;
+is($a, "\x{100}");
+
+$a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
+is($a, "\x{1ff}\x{1fe}");
+
+
+# From David Dyck
 ($a = "R0_001") =~ tr/R_//d;
-print "not " if hex($a) != 1;
-print "ok 52\n";
+is(hex($a), 1);
 
+# From Inaba Hiroto
 @a = (1,2); map { y/1/./ for $_ } @a;
-print "not " if "@a" ne ". 2";
-print "ok 53\n";
+is("@a", ". 2");
 
 @a = (1,2); map { y/1/./ for $_.'' } @a;
-print "not " if "@a" ne "1 2";
-print "ok 54\n";
+is("@a", "1 2");
+
+
+# Additional test for Inaba Hiroto patch (robin@kitsite.com)
+($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c;
+is($a, "XZY");
+
+
+# Used to fail with "Modification of a read-only value attempted"
+%a = (N=>1);
+foreach (keys %a) {
+  eval 'tr/N/n/';
+  is($_, 'n',   'pp_trans needs to unshare shared hash keys');
+  is($@, '',    '   no error');
+}
+
+
+$x = eval '"1213" =~ tr/1/1/';
+is($x, 2,   'implicit count on constant');
+is($@, '',  '   no error');
+
+
+my @foo = ();
+eval '$foo[-1] =~ tr/N/N/';
+is( $@, '',         'implicit count outside array bounds, index negative' );
+is( scalar @foo, 0, "    doesn't extend the array");
+
+eval '$foo[1] =~ tr/N/N/';
+is( $@, '',         'implicit count outside array bounds, index positive' );
+is( scalar @foo, 0, "    doesn't extend the array");
+
+
+my %foo = ();
+eval '$foo{bar} =~ tr/N/N/';
+is( $@, '',         'implicit count outside hash bounds' );
+is( scalar keys %foo, 0,   "    doesn't extend the hash");
diff --git a/gnu/usr.bin/perl/t/op/utf8decode.t b/gnu/usr.bin/perl/t/op/utf8decode.t
index 4d05a6b8d37..499049aab93 100644
--- a/gnu/usr.bin/perl/t/op/utf8decode.t
+++ b/gnu/usr.bin/perl/t/op/utf8decode.t
@@ -5,6 +5,20 @@ BEGIN {
     @INC = '../lib';
 }
 
+{
+    my $wide = v256;
+    use bytes;
+    my $ordwide = ord($wide);
+    printf "# under use bytes ord(v256) = 0x%02x\n", $ordwide;
+    if ($ordwide == 140) {
+	print "1..0 # Skip: UTF-EBCDIC (not UTF-8) used here\n";
+	exit 0;
+    }
+    elsif ($ordwide != 196) {
+	printf "# v256 starts with 0x%02x\n", $ordwide;
+    }
+}
+
 no utf8;
 
 print "1..78\n";
@@ -13,7 +27,7 @@ my $test = 1;
 
 # This table is based on Markus Kuhn's UTF-8 Decode Stress Tester,
 # http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt,
-# version dated 2000-09-02. 
+# version dated 2000-09-02.
 
 # We use the \x notation instead of raw binary bytes for \x00-\x1f\x7f-\xff
 # because e.g. many patch programs have issues with binary data.
@@ -21,7 +35,7 @@ my $test = 1;
 my @MK = split(/\n/, <<__EOMK__);
 1	Correct UTF-8
 1.1.1 y "\xce\xba\xe1\xbd\xb9\xcf\x83\xce\xbc\xce\xb5"	-		11	ce:ba:e1:bd:b9:cf:83:ce:bc:ce:b5	5
-2	Boundary conditions 
+2	Boundary conditions
 2.1	First possible sequence of certain length
 2.1.1 y "\x00"			0		1	00	1
 2.1.2 y "\xc2\x80"			80		2	c2:80	1
@@ -122,24 +136,21 @@ __EOMK__
 
 # 104..181
 {
-    my $WARNCNT;
     my $id;
 
-    local $SIG{__WARN__} =
-	sub {
-	    print "# $id: @_";
-	    $WARNCNT++;
-	    $WARNMSG = "@_";
-	};
+    local $SIG{__WARN__} = sub {
+	print "# $id: @_";
+	$@ = "@_";
+    };
 
     sub moan {
 	print "$id: @_";
     }
-    
-    sub test_unpack_U {
-	$WARNCNT = 0;
-	$WARNMSG = "";
-	unpack('U*', $_[0]);
+
+    sub warn_unpack_U {
+	$@ = '';
+	my @null = unpack('U0U*', $_[0]);
+	return $@;
     }
 
     for (@MK) {
@@ -147,7 +158,7 @@ __EOMK__
 	    # print "# $_\n";
 	} elsif (/^(\d+\.\d+\.\d+[bu]?)\s+([yn])\s+"(.+)"\s+([0-9a-f]{1,8}|-)\s+(\d+)\s+([0-9a-f]{2}(?::[0-9a-f]{2})*)(?:\s+((?:\d+|-)(?:\s+(.+))?))?$/) {
 	    $id = $1;
-	    my ($okay, $bytes, $Unicode, $byteslen, $hex, $charslen, $error) =
+	    my ($okay, $bytes, $Unicode, $byteslen, $hex, $charslen, $experr) =
 		($2, $3, $4, $5, $6, $7, $8);
 	    my @hex = split(/:/, $hex);
 	    unless (@hex == $byteslen) {
@@ -161,20 +172,19 @@ __EOMK__
 		    moan "bytes length() ($bytesbyteslen) not equal to $byteslen\n";
 		}
 	    }
+	    my $warn = warn_unpack_U($bytes);
 	    if ($okay eq 'y') {
-		test_unpack_U($bytes);
-		if ($WARNCNT) {
-		    moan "unpack('U*') false negative\n";
+		if ($warn) {
+		    moan "unpack('U0U*') false negative\n";
 		    print "not ";
 		}
 	    } elsif ($okay eq 'n') {
-		test_unpack_U($bytes);
-		if ($WARNCNT == 0 || ($error ne '' && $WARNMSG !~ /$error/)) {
-		    moan "unpack('U*') false positive\n";
+		if (not $warn || ($experr ne '' && $warn !~ /$experr/)) {
+		    moan "unpack('U0U*') false positive\n";
 		    print "not ";
 		}
 	    }
-	    print "ok $test\n";
+	    print "ok $test # $id $okay\n";
 	    $test++;
  	} else {
 	    moan "unknown format\n";
diff --git a/gnu/usr.bin/perl/t/op/utfhash.t b/gnu/usr.bin/perl/t/op/utfhash.t
new file mode 100644
index 00000000000..af7e6c12960
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/utfhash.t
@@ -0,0 +1,172 @@
+#!./perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+
+    plan(tests => 91);
+}
+
+use strict;
+
+# Two hashes one will all keys 8-bit possible (initially), other
+# with a utf8 requiring key from the outset.
+
+my %hash8 = ( "\xff" => 0xff,
+              "\x7f" => 0x7f,
+            );
+my %hashu = ( "\xff" => 0xff,
+              "\x7f" => 0x7f,
+              "\x{1ff}" => 0x1ff,
+            );
+
+# Check that we can find the 8-bit things by various litterals
+is($hash8{"\x{00ff}"},0xFF);
+is($hash8{"\x{007f}"},0x7F);
+is($hash8{"\xff"},0xFF);
+is($hash8{"\x7f"},0x7F);
+is($hashu{"\x{00ff}"},0xFF);
+is($hashu{"\x{007f}"},0x7F);
+is($hashu{"\xff"},0xFF);
+is($hashu{"\x7f"},0x7F);
+
+# Now try same thing with variables forced into various forms.
+foreach my $a ("\x7f","\xff")
+ {
+  utf8::upgrade($a);
+  is($hash8{$a},ord($a));
+  is($hashu{$a},ord($a));
+  utf8::downgrade($a);
+  is($hash8{$a},ord($a));
+  is($hashu{$a},ord($a));
+  my $b = $a.chr(100);
+  chop($b);
+  is($hash8{$b},ord($b));
+  is($hashu{$b},ord($b));
+ }
+
+# Check we have not got an spurious extra keys
+is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff");
+is(join('',sort { ord $a <=> ord $b } keys %hashu),"\x7f\xff\x{1ff}");
+
+# Now add a utf8 key to the 8-bit hash
+$hash8{chr(0x1ff)} = 0x1ff;
+
+# Check we have not got an spurious extra keys
+is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff\x{1ff}");
+
+foreach my $a ("\x7f","\xff","\x{1ff}")
+ {
+  utf8::upgrade($a);
+  is($hash8{$a},ord($a));
+  my $b = $a.chr(100);
+  chop($b);
+  is($hash8{$b},ord($b));
+ }
+
+# and remove utf8 from the other hash
+is(delete $hashu{chr(0x1ff)},0x1ff);
+is(join('',sort keys %hashu),"\x7f\xff");
+
+foreach my $a ("\x7f","\xff")
+ {
+  utf8::upgrade($a);
+  is($hashu{$a},ord($a));
+  utf8::downgrade($a);
+  is($hashu{$a},ord($a));
+  my $b = $a.chr(100);
+  chop($b);
+  is($hashu{$b},ord($b));
+ }
+
+
+
+{
+  print "# Unicode hash keys and \\w\n";
+  # This is not really a regex test but regexes bring
+  # out the issue nicely.
+  use strict;
+  my $u3 = "f\x{df}\x{100}";
+  my $u2 = substr($u3,0,2);
+  my $u1 = substr($u2,0,1);
+  my $u0 = chr (0xdf)x4; # Make this 4 chars so that all lengths are distinct.
+
+  my @u = ($u0, $u1, $u2, $u3);
+
+  while (@u) {
+    my %u = (map {( $_, $_)} @u);
+    my $keys = scalar @u;
+    $keys .= ($keys == 1) ? " key" : " keys";
+
+    for (keys %u) {
+        my $l = 0 + /^\w+$/;
+        my $r = 0 + $u{$_} =~ /^\w+$/;
+	is ($l, $r, "\\w on keys with $keys, key of length " . length $_);
+    }
+
+    my $more;
+    do {
+      $more = 0;
+      # Want to do this direct, rather than copying to a temporary variable
+      # The first time each will return key and value at the start of the hash.
+      # each will return () after we've done the last pair. $more won't get
+      # set then, and the do will exit.
+      for (each %u) {
+        $more = 1;
+        my $l = 0 + /^\w+$/;
+        my $r = 0 + $u{$_} =~ /^\w+$/;
+        is ($l, $r, "\\w on each, with $keys, key of length " . length $_);
+      }
+    } while ($more);
+
+    for (%u) {
+      my $l = 0 + /^\w+$/;
+      my $r = 0 + $u{$_} =~ /^\w+$/;
+      is ($l, $r, "\\w on hash with $keys, key of length " . length $_);
+    }
+    pop @u;
+    undef %u;
+  }
+}
+
+{
+  my $utf8_sz = my $bytes_sz = "\x{df}";
+  $utf8_sz .= chr 256;
+  chop ($utf8_sz);
+
+  my (%bytes_first, %utf8_first);
+
+  $bytes_first{$bytes_sz} = $bytes_sz;
+
+  for (keys %bytes_first) {
+    my $l = 0 + /^\w+$/;
+    my $r = 0 + $bytes_first{$_} =~ /^\w+$/;
+    is ($l, $r, "\\w on each, bytes");
+  }
+
+  $bytes_first{$utf8_sz} = $utf8_sz;
+
+  for (keys %bytes_first) {
+    my $l = 0 + /^\w+$/;
+    my $r = 0 + $bytes_first{$_} =~ /^\w+$/;
+    is ($l, $r, "\\w on each, bytes now utf8");
+  }
+
+  $utf8_first{$utf8_sz} = $utf8_sz;
+
+  for (keys %utf8_first) {
+    my $l = 0 + /^\w+$/;
+    my $r = 0 + $utf8_first{$_} =~ /^\w+$/;
+    is ($l, $r, "\\w on each, utf8");
+  }
+
+  $utf8_first{$bytes_sz} = $bytes_sz;
+
+  for (keys %utf8_first) {
+    my $l = 0 + /^\w+$/;
+    my $r = 0 + $utf8_first{$_} =~ /^\w+$/;
+    is ($l, $r, "\\w on each, utf8 now bytes");
+  }
+
+}
diff --git a/gnu/usr.bin/perl/t/op/ver.t b/gnu/usr.bin/perl/t/op/ver.t
index edfebd20ffc..1634cc340fe 100644
--- a/gnu/usr.bin/perl/t/op/ver.t
+++ b/gnu/usr.bin/perl/t/op/ver.t
@@ -2,41 +2,42 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    @INC = '../lib';
+    @INC = qw(. ../lib);
+    $SIG{'__WARN__'} = sub { warn $_[0] if $DOWARN };
 }
 
-print "1..28\n";
+$DOWARN = 1; # enable run-time warnings now
 
-my $test = 1;
+use Config;
 
-use v5.5.640;
-require v5.5.640;
-print "ok $test\n";  ++$test;
+require "test.pl";
+plan( tests => 47 );
+
+eval { use v5.5.640; };
+is( $@, '', "use v5.5.640; $@");
+
+require_ok('v5.5.640');
 
 # printing characters should work
 if (ord("\t") == 9) { # ASCII
-    print v111;
-    print v107.32;
-    print "$test\n"; ++$test;
+    is('ok ',v111.107.32,'ASCII printing characters');
 
     # hash keys too
     $h{v111.107} = "ok";
-    print "$h{ok} $test\n"; ++$test;
+    is('ok',$h{v111.107},'ASCII hash keys');
 }
 else { # EBCDIC
-    print v150;
-    print v146.64;
-    print "$test\n"; ++$test;
+    is('ok ',v150.146.64,'EBCDIC printing characters');
 
     # hash keys too
     $h{v150.146} = "ok";
-    print "$h{ok} $test\n"; ++$test;
+    is('ok',$h{v150.146},'EBCDIC hash keys');
 }
 
 # poetry optimization should also
 sub v77 { "ok" }
 $x = v77;
-print "$x $test\n"; ++$test;
+is('ok',$x,'poetry optimization');
 
 # but not when dots are involved
 if (ord("\t") == 9) { # ASCII
@@ -45,17 +46,16 @@ if (ord("\t") == 9) { # ASCII
 else {
     $x = v212.213.214;
 }
-print "not " unless $x eq "MNO";
-print "ok $test\n";  ++$test;
+is($x, 'MNO','poetry optimization with dots');
 
-print "not " unless v1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}";
-print "ok $test\n";  ++$test;
+is(v1.20.300.4000, "\x{1}\x{14}\x{12c}\x{fa0}",'compare embedded \x{} string');
 
 #
 # now do the same without the "v"
-use 5.5.640;
-require 5.5.640;
-print "ok $test\n";  ++$test;
+eval { use 5.5.640; };
+is( $@, '', "use 5.5.640; $@");
+
+require_ok('5.5.640');
 
 # hash keys too
 if (ord("\t") == 9) { # ASCII
@@ -64,7 +64,7 @@ if (ord("\t") == 9) { # ASCII
 else {
     $h{150.146.64} = "ok";
 }
-print "$h{ok } $test\n"; ++$test;
+is('ok',$h{ok },'hash keys w/o v');
 
 if (ord("\t") == 9) { # ASCII
     $x = 77.78.79;
@@ -72,110 +72,176 @@ if (ord("\t") == 9) { # ASCII
 else {
     $x = 212.213.214;
 }
-print "not " unless $x eq "MNO";
-print "ok $test\n";  ++$test;
+is($x, 'MNO','poetry optimization with dots w/o v');
 
-print "not " unless 1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}";
-print "ok $test\n";  ++$test;
+is(1.20.300.4000, "\x{1}\x{14}\x{12c}\x{fa0}",'compare embedded \x{} string w/o v');
 
 # test sprintf("%vd"...) etc
 if (ord("\t") == 9) { # ASCII
-    print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108';
+    is(sprintf("%vd", "Perl"), '80.101.114.108', 'ASCII sprintf("%vd", "Perl")');
 }
 else {
-    print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147';
+    is(sprintf("%vd", "Perl"), '215.133.153.147', 'EBCDIC sprintf("%vd", "Perl")');
 }
-print "ok $test\n";  ++$test;
 
-print "not " unless sprintf("%vd", v1.22.333.4444) eq '1.22.333.4444';
-print "ok $test\n";  ++$test;
+is(sprintf("%vd", v1.22.333.4444), '1.22.333.4444', 'sprintf("%vd", v1.22.333.4444)');
 
 if (ord("\t") == 9) { # ASCII
-    print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c';
+    is(sprintf("%vx", "Perl"), '50.65.72.6c', 'ASCII sprintf("%vx", "Perl")');
 }
 else {
-    print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93';
+    is(sprintf("%vx", "Perl"), 'd7.85.99.93', 'EBCDIC sprintf("%vx", "Perl")');
 }
-print "ok $test\n";  ++$test;
 
-print "not " unless sprintf("%vX", 1.22.333.4444) eq '1.16.14D.115C';
-print "ok $test\n";  ++$test;
+is(sprintf("%vX", 1.22.333.4444), '1.16.14D.115C','ASCII sprintf("%vX", 1.22.333.4444)');
 
 if (ord("\t") == 9) { # ASCII
-    print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154';
+    is(sprintf("%#*vo", ":", "Perl"), '0120:0145:0162:0154', 'ASCII sprintf("%vo", "Perl")');
 }
 else {
-    print "not " unless sprintf("%*v#o", ":", "Perl") eq '0327:0205:0231:0223';
+    is(sprintf("%#*vo", ":", "Perl"), '0327:0205:0231:0223', 'EBCDIC sprintf("%vo", "Perl")');
 }
-print "ok $test\n";  ++$test;
 
-print "not " unless sprintf("%*vb", "##", v1.22.333.4444)
-    eq '1##10110##101001101##1000101011100';
-print "ok $test\n";  ++$test;
+is(sprintf("%*vb", "##", v1.22.333.4444),
+    '1##10110##101001101##1000101011100', 'sprintf("%vb", 1.22.333.4444)');
 
-print "not " unless sprintf("%vd", join("", map { chr }
-					    unpack "U*", v2001.2002.2003))
-		    eq '2001.2002.2003';
-print "ok $test\n";  ++$test;
+is(sprintf("%vd", join("", map { chr }
+			 unpack 'U*', pack('U*',2001,2002,2003))),
+     '2001.2002.2003','unpack/pack U*');
 
 {
     use bytes;
+
     if (ord("\t") == 9) { # ASCII
-        print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108';
+	is(sprintf("%vd", "Perl"), '80.101.114.108', 'ASCII sprintf("%vd", "Perl") w/use bytes');
     }
     else {
-        print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147';
+	is(sprintf("%vd", "Perl"), '215.133.153.147', 'EBCDIC sprintf("%vd", "Perl") w/use bytes');
     }
-    print "ok $test\n";  ++$test;
 
-    print "not " unless
-        sprintf("%vd", 1.22.333.4444) eq '1.22.197.141.225.133.156';
-    print "ok $test\n";  ++$test;
+    if (ord("\t") == 9) { # ASCII
+	is(sprintf("%vd", 1.22.333.4444), '1.22.197.141.225.133.156', 'ASCII sprintf("%vd", v1.22.333.4444 w/use bytes');
+    }
+    else {
+	is(sprintf("%vd", 1.22.333.4444), '1.22.142.84.187.81.112', 'EBCDIC sprintf("%vd", v1.22.333.4444 w/use bytes');
+    }
 
     if (ord("\t") == 9) { # ASCII
-        print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c';
+	is(sprintf("%vx", "Perl"), '50.65.72.6c', 'ASCII sprintf("%vx", "Perl")');
     }
     else {
-        print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93';
+	is(sprintf("%vx", "Perl"), 'd7.85.99.93', 'EBCDIC sprintf("%vx", "Perl")');
     }
-    print "ok $test\n";  ++$test;
 
-    print "not " unless sprintf("%vX", v1.22.333.4444) eq '1.16.C5.8D.E1.85.9C';
-    print "ok $test\n";  ++$test;
+    if (ord("\t") == 9) { # ASCII
+	is(sprintf("%vX", v1.22.333.4444), '1.16.C5.8D.E1.85.9C', 'ASCII sprintf("%vX", v1.22.333.4444)');
+    }
+    else {
+	is(sprintf("%vX", v1.22.333.4444), '1.16.8E.54.BB.51.70', 'EBCDIC sprintf("%vX", v1.22.333.4444)');
+    }
 
     if (ord("\t") == 9) { # ASCII
-        print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154';
+	is(sprintf("%#*vo", ":", "Perl"), '0120:0145:0162:0154', 'ASCII sprintf("%#*vo", ":", "Perl")');
     }
     else {
-        print "not " unless sprintf("%*v#o", ":", "Perl") eq '0327:0205:0231:0223';
+	is(sprintf("%#*vo", ":", "Perl"), '0327:0205:0231:0223', 'EBCDIC sprintf("%#*vo", ":", "Perl")');
     }
-    print "ok $test\n";  ++$test;
 
-    print "not " unless sprintf("%*vb", "##", v1.22.333.4444)
-	eq '1##10110##11000101##10001101##11100001##10000101##10011100';
-    print "ok $test\n";  ++$test;
+    if (ord("\t") == 9) { # ASCII
+	is(sprintf("%*vb", "##", v1.22.333.4444),
+	     '1##10110##11000101##10001101##11100001##10000101##10011100',
+	     'ASCII sprintf("%*vb", "##", v1.22.333.4444)');
+    }
+    else {
+	is(sprintf("%*vb", "##", v1.22.333.4444),
+            '1##10110##10001110##1010100##10111011##1010001##1110000',
+	    'EBCDIC sprintf("%*vb", "##", v1.22.333.4444)');
+    }
 }
 
 {
     # bug id 20000323.056
 
-    print "not " unless "\x{41}" eq +v65;
-    print "ok $test\n";
-    $test++;
+    is( "\x{41}",      +v65, 'bug id 20000323.056');
+    is( "\x41",        +v65, 'bug id 20000323.056');
+    is( "\x{c8}",     +v200, 'bug id 20000323.056');
+    is( "\xc8",       +v200, 'bug id 20000323.056');
+    is( "\x{221b}",  +v8731, 'bug id 20000323.056');
+}
 
-    print "not " unless "\x41" eq +v65;
-    print "ok $test\n";
-    $test++;
+# See if the things Camel-III says are true: 29..33
 
-    print "not " unless "\x{c8}" eq +v200;
-    print "ok $test\n";
-    $test++;
+# Chapter 2 pp67/68
+my $vs = v1.20.300.4000;
+is($vs,"\x{1}\x{14}\x{12c}\x{fa0}","v-string ne \\x{}");
+is($vs,chr(1).chr(20).chr(300).chr(4000),"v-string ne chr()");
+is('foo',((chr(193) eq 'A') ? v134.150.150 : v102.111.111),"v-string ne ''");
 
-    print "not " unless "\xc8" eq +v200;
-    print "ok $test\n";
-    $test++;
+# Chapter 15, pp403
 
-    print "not " unless "\x{221b}" eq v8731;
-    print "ok $test\n";
-    $test++;
+# See if sane addr and gethostbyaddr() work
+eval { require Socket; gethostbyaddr(v127.0.0.1, &Socket::AF_INET) };
+if ($@) {
+    # No - so do not test insane fails.
+    $@ =~ s/\n/\n# /g;
+}
+SKIP: {
+    skip("No Socket::AF_INET # $@") if $@;
+    my $ip   = v2004.148.0.1;
+    my $host;
+    eval { $host = gethostbyaddr($ip,&Socket::AF_INET) };
+    like($@, qr/Wide character/, "Non-bytes leak to gethostbyaddr");
+}
+
+# Chapter 28, pp671
+ok(v5.6.0 lt v5.7.0, "v5.6.0 lt v5.7.0");
+
+# part of 20000323.059
+is(v200, chr(200),      "v200 eq chr(200)"      );
+is(v200, +v200,         "v200 eq +v200"         );
+is(v200, eval( "v200"), 'v200 eq "v200"'        );
+is(v200, eval("+v200"), 'v200 eq eval("+v200")' );
+
+# Tests for string/numeric value of $] itself
+my ($revision,$version,$subversion) = split '\.', sprintf("%vd",$^V);
+
+print "# revision   = '$revision'\n";
+print "# version    = '$version'\n";
+print "# subversion = '$subversion'\n";
+
+my $v = sprintf("%d.%.3d%.3d",$revision,$version,$subversion);
+
+print "# v = '$v'\n";
+print "# ] = '$]'\n";
+
+$v =~ s/000$// if $subversion == 0;
+
+print "# v = '$v'\n";
+
+ok( $v eq "$]", qq{\$^V eq "\$]"});
+
+$v = $revision + $version/1000 + $subversion/1000000;
+
+ok( $v == $], "\$^V == \$] (numeric)" );
+
+SKIP: {
+  skip("In EBCDIC the v-string components cannot exceed 2147483647", 6)
+    if ord "A" == 193;
+
+  # [ID 20010902.001] check if v-strings handle full UV range or not
+  if ( $Config{'uvsize'} >= 4 ) {
+    is(  sprintf("%vd", eval 'v2147483647.2147483648'),   '2147483647.2147483648', 'v-string > IV_MAX[32-bit]' );
+    is(  sprintf("%vd", eval 'v3141592653'),              '3141592653',            'IV_MAX < v-string < UV_MAX[32-bit]');
+    is(  sprintf("%vd", eval 'v4294967295'),              '4294967295',            'v-string == UV_MAX[32-bit] - 1');
+  }
+
+  SKIP: {
+    skip("No quads", 3) if $Config{uvsize} < 8;
+
+    if ( $Config{'uvsize'} >= 8 ) {
+      is(  sprintf("%vd", eval 'v9223372036854775807.9223372036854775808'),   '9223372036854775807.9223372036854775808', 'v-string > IV_MAX[64-bit]' );
+      is(  sprintf("%vd", eval 'v17446744073709551615'),                      '17446744073709551615',                    'IV_MAX < v-string < UV_MAX[64-bit]');
+      is(  sprintf("%vd", eval 'v18446744073709551615'),                      '18446744073709551615',                    'v-string == UV_MAX[64-bit] - 1');
+    }
+  }
 }
diff --git a/gnu/usr.bin/perl/t/op/wantarray.t b/gnu/usr.bin/perl/t/op/wantarray.t
index 4b6f37cf0fa..28936f419cc 100644
--- a/gnu/usr.bin/perl/t/op/wantarray.t
+++ b/gnu/usr.bin/perl/t/op/wantarray.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..7\n";
+print "1..9\n";
 sub context {
   my ( $cona, $testnum ) = @_;
   my $conb = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V';
@@ -17,4 +17,18 @@ scalar context('S',4);
 $a = scalar context('S',5);
 ($a) = context('A',6);
 ($a) = scalar context('S',7);
+
+{
+  # [ID 20020626.011] incorrect wantarray optimisation
+  sub simple { wantarray ? 1 : 2 }
+  sub inline {
+    my $a = wantarray ? simple() : simple();
+    $a;
+  }
+  my @b = inline();
+  my $c = inline();
+  print +(@b == 1 && "@b" eq "2") ? "ok 8\n" : "not ok 8\t# <@b>\n";
+  print +($c == 2) ? "ok 9\n" : "not ok 9\t# <$c>\n";
+}
+
 1;
diff --git a/gnu/usr.bin/perl/t/pod/plainer.t b/gnu/usr.bin/perl/t/pod/plainer.t
new file mode 100644
index 00000000000..293edbbe17e
--- /dev/null
+++ b/gnu/usr.bin/perl/t/pod/plainer.t
@@ -0,0 +1,57 @@
+#!./perl
+
+BEGIN { chdir 't' if -d 't'; @INC = '../lib' }
+
+use Pod::Plainer;
+my $parser = Pod::Plainer->new();
+my $header = "=pod\n\n";
+my $input  = 'plnr_in.pod';
+my $output = 'plnr_out.pod';
+
+my $test = 0;
+print "1..7\n";
+while( <DATA> ) {
+    my $expected = $header.<DATA>; 
+
+    open(IN, '>', $input) or die $!;
+    print IN $header, $_;
+    close IN or die $!;
+
+    open IN, '<', $input or die $!;
+    open OUT, '>', $output or die $!;
+    $parser->parse_from_filehandle(\*IN,\*OUT);
+
+    open OUT, '<', $output or die $!;
+    my $returned; { local $/; $returned = <OUT>; }
+    
+    unless( $returned eq $expected ) {
+       print map { s/^/\#/mg; $_; }
+               map {+$_}               # to avoid readonly values
+                   "EXPECTED:\n", $expected, "GOT:\n", $returned;
+       print "not ";
+    }
+    printf "ok %d\n", ++$test; 
+    close OUT;
+    close IN;
+}
+
+END { 
+    1 while unlink $input;
+    1 while unlink $output;
+}
+
+__END__
+=head <> now reads in records
+=head E<lt>E<gt> now reads in records
+=item C<-T> and C<-B> not implemented on filehandles
+=item C<-T> and C<-B> not implemented on filehandles
+e.g. C<< Foo->bar() >> or C<< $obj->bar() >>
+e.g. C<Foo-E<gt>bar()> or C<$obj-E<gt>bar()>
+The C<< => >> operator is mostly just a more visually distinctive
+The C<=E<gt>> operator is mostly just a more visually distinctive
+C<uv < 0x80> in which case you can use C<*s = uv>.
+C<uv E<lt> 0x80> in which case you can use C<*s = uv>.
+C<time ^ ($$ + ($$ << 15))>), but that isn't necessary any more.
+C<time ^ ($$ + ($$ E<lt>E<lt> 15))>), but that isn't necessary any more.
+The bitwise operation C<<< >> >>>
+The bitwise operation C<E<gt>E<gt>>
diff --git a/gnu/usr.bin/perl/t/pod/testpods/lib/Pod/Stuff.pm b/gnu/usr.bin/perl/t/pod/testpods/lib/Pod/Stuff.pm
new file mode 100644
index 00000000000..d5c11203037
--- /dev/null
+++ b/gnu/usr.bin/perl/t/pod/testpods/lib/Pod/Stuff.pm
@@ -0,0 +1,20 @@
+=head1 NAME
+
+Pod::Stuff - dummy testing pod
+
+=head1 DESCRIPTION
+
+This isn't really anything, its just some dummy pod code.
+And stuff.
+
+Lots of stuff.
+
+=head2 STUFF
+
+For all your stuff [tm]
+
+Stuffit
+
+Mmmm, stuffed pizza bread.
+
+=cut
diff --git a/gnu/usr.bin/perl/t/run/exit.t b/gnu/usr.bin/perl/t/run/exit.t
new file mode 100644
index 00000000000..53ba4ea76bf
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/exit.t
@@ -0,0 +1,71 @@
+#!./perl
+#
+# Tests for perl exit codes, playing with $?, etc...
+
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(. ../lib);
+}
+
+# VMS and Windows need -e "...", most everything else works better with '
+my $quote = $^O =~ /^(VMS|MSWin\d+)$/ ? q{"} : q{'};
+
+# Run some code, return its wait status.
+sub run {
+    my($code) = shift;
+    my $cmd = "$^X -e ";
+    return system($cmd.$quote.$code.$quote);
+}
+
+BEGIN {
+    # MacOS system() doesn't have good return value
+    $numtests = ($^O eq 'VMS') ? 7 : ($^O eq 'MacOS') ? 0 : 3; 
+}
+
+require "test.pl";
+plan(tests => $numtests);
+
+if ($^O ne 'MacOS') {
+my $exit, $exit_arg;
+
+$exit = run('exit');
+is( $exit >> 8, 0,              'Normal exit' );
+
+if ($^O ne 'VMS') {
+
+  $exit = run('exit 42');
+  is( $exit >> 8, 42,             'Non-zero exit' );
+
+} else {
+
+# On VMS, successful returns from system() are always 0, warnings are 1,
+# errors are 2, and fatal errors are 4.
+
+  $exit = run("exit 196609"); # %CLI-S-NORMAL
+  is( $exit >> 8, 0,             'success exit' );
+
+  $exit = run("exit 196611");  # %CLI-I-NORMAL
+  is( $exit >> 8, 0,             'informational exit' );
+
+  $exit = run("exit 196608");  # %CLI-W-NORMAL
+  is( $exit >> 8, 1,             'warning exit' );
+
+  $exit = run("exit 196610");  # %CLI-E-NORMAL
+  is( $exit >> 8, 2,             'error exit' );
+
+  $exit = run("exit 196612");  # %CLI-F-NORMAL
+  is( $exit >> 8, 4,             'fatal error exit' );
+}
+
+$exit_arg = 42;
+$exit = run("END { \$? = $exit_arg }");
+
+# On VMS, in the child process the actual exit status will be SS$_ABORT, 
+# which is what you get from any non-zero value of $? that has been 
+# dePOSIXified by STATUS_POSIX_SET.  In the parent process, all we'll 
+# see are the severity bits (0-2) shifted left by 8.
+$exit_arg = (44 & 7) if $^O eq 'VMS';  
+
+is( $exit >> 8, $exit_arg,             'Changing $? in END block' );
+}
diff --git a/gnu/usr.bin/perl/t/run/fresh_perl.t b/gnu/usr.bin/perl/t/run/fresh_perl.t
new file mode 100644
index 00000000000..9c2b42fc033
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/fresh_perl.t
@@ -0,0 +1,846 @@
+#!./perl
+
+# ** DO NOT ADD ANY MORE TESTS HERE **
+# Instead, put the test in the appropriate test file and use the 
+# fresh_perl_is()/fresh_perl_like() functions in t/test.pl.
+
+# This is for tests that will normally cause segfaults, and other nasty
+# errors that might kill the interpreter and for some reason you can't
+# use an eval().
+#
+# New tests are added to the bottom.  For example.
+#
+#       ######## perlbug ID 20020831.001
+#       ($a, b) = (1,2)
+#       EXPECT
+#       Can't modify constant item in list assignment - at line 1
+#
+# to test that the code "($a, b) = (1,2)" causes the appropriate syntax
+# error, rather than just segfaulting as reported in perlbug ID
+# 20020831.001
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';	# for which_perl() etc
+}
+
+use strict;
+
+my $Perl = which_perl();
+
+$|=1;
+
+my @prgs = ();
+while(<DATA>) { 
+    if(m/^#{8,}\s*(.*)/) { 
+        push @prgs, ['', $1];
+    }
+    else { 
+        $prgs[-1][0] .= $_;
+    }
+}
+plan tests => scalar @prgs;
+
+foreach my $prog (@prgs) {
+    my($raw_prog, $name) = @$prog;
+
+    my $switch;
+    if ($raw_prog =~ s/^\s*(-\w.*)//){
+	$switch = $1;
+    }
+
+    my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog);
+
+    if ($prog =~ /^\# SKIP: (.+)/m) {
+	if (eval $1) {
+	    ok(1, "Skip: $1");
+	    next;
+	}
+    }
+
+    $expected =~ s/\n+$//;
+
+    fresh_perl_is($prog, $expected, { switches => [$switch] }, $name);
+}
+
+__END__
+########
+$a = ":="; split /($a)/o, "a:=b:=c"; print "@_"
+EXPECT
+a := b := c
+########
+$cusp = ~0 ^ (~0 >> 1);
+use integer;
+$, = " ";
+print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n";
+EXPECT
+7 0 0 8 !
+########
+$foo=undef; $foo->go;
+EXPECT
+Can't call method "go" on an undefined value at - line 1.
+########
+BEGIN
+        {
+	    "foo";
+        }
+########
+$array[128]=1
+########
+$x=0x0eabcd; print $x->ref;
+EXPECT
+Can't call method "ref" without a package or object reference at - line 1.
+########
+chop ($str .= <DATA>);
+########
+close ($banana);
+########
+$x=2;$y=3;$x<$y ? $x : $y += 23;print $x;
+EXPECT
+25
+########
+eval {sub bar {print "In bar";}}
+########
+system './perl -ne "print if eof" /dev/null' unless $^O eq 'MacOS'
+########
+chop($file = <DATA>);
+########
+package N;
+sub new {my ($obj,$n)=@_; bless \$n}  
+$aa=new N 1;
+$aa=12345;
+print $aa;
+EXPECT
+12345
+########
+%@x=0;
+EXPECT
+Can't modify hash dereference in repeat (x) at - line 1, near "0;"
+Execution of - aborted due to compilation errors.
+########
+$_="foo";
+printf(STDOUT "%s\n", $_);
+EXPECT
+foo
+########
+push(@a, 1, 2, 3,)
+########
+quotemeta ""
+########
+for ("ABCDE") {
+ &sub;
+s/./&sub($&)/eg;
+print;}
+sub sub {local($_) = @_;
+$_ x 4;}
+EXPECT
+Modification of a read-only value attempted at - line 3.
+########
+package FOO;sub new {bless {FOO => BAR}};
+package main;
+use strict vars;   
+my $self = new FOO;
+print $$self{FOO};
+EXPECT
+BAR
+########
+$_="foo";
+s/.{1}//s;
+print;
+EXPECT
+oo
+########
+print scalar ("foo","bar")
+EXPECT
+bar
+########
+sub by_number { $a <=> $b; };# inline function for sort below
+$as_ary{0}="a0";
+@ordered_array=sort by_number keys(%as_ary);
+########
+sub NewShell
+{
+  local($Host) = @_;
+  my($m2) = $#Shells++;
+  $Shells[$m2]{HOST} = $Host;
+  return $m2;
+}
+ 
+sub ShowShell
+{
+  local($i) = @_;
+}
+ 
+&ShowShell(&NewShell(beach,Work,"+0+0"));
+&ShowShell(&NewShell(beach,Work,"+0+0"));
+&ShowShell(&NewShell(beach,Work,"+0+0"));
+########
+   {
+       package FAKEARRAY;
+   
+       sub TIEARRAY
+       { print "TIEARRAY @_\n"; 
+         die "bomb out\n" unless $count ++ ;
+         bless ['foo'] 
+       }
+       sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] }
+       sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] }
+       sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; }
+   }
+   
+eval 'tie @h, FAKEARRAY, fred' ;
+tie @h, FAKEARRAY, fred ;
+EXPECT
+TIEARRAY FAKEARRAY fred
+TIEARRAY FAKEARRAY fred
+DESTROY 
+########
+BEGIN { die "phooey\n" }
+EXPECT
+phooey
+BEGIN failed--compilation aborted at - line 1.
+########
+BEGIN { 1/$zero }
+EXPECT
+Illegal division by zero at - line 1.
+BEGIN failed--compilation aborted at - line 1.
+########
+BEGIN { undef = 0 }
+EXPECT
+Modification of a read-only value attempted at - line 1.
+BEGIN failed--compilation aborted at - line 1.
+########
+{
+    package foo;
+    sub PRINT {
+        shift;
+        print join(' ', reverse @_)."\n";
+    }
+    sub PRINTF {
+        shift;
+	  my $fmt = shift;
+        print sprintf($fmt, @_)."\n";
+    }
+    sub TIEHANDLE {
+        bless {}, shift;
+    }
+    sub READLINE {
+	"Out of inspiration";
+    }
+    sub DESTROY {
+	print "and destroyed as well\n";
+  }
+  sub READ {
+      shift;
+      print STDOUT "foo->can(READ)(@_)\n";
+      return 100; 
+  }
+  sub GETC {
+      shift;
+      print STDOUT "Don't GETC, Get Perl\n";
+      return "a"; 
+  }    
+}
+{
+    local(*FOO);
+    tie(*FOO,'foo');
+    print FOO "sentence.", "reversed", "a", "is", "This";
+    print "-- ", <FOO>, " --\n";
+    my($buf,$len,$offset);
+    $buf = "string";
+    $len = 10; $offset = 1;
+    read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed";
+    getc(FOO) eq "a" or die "foo->GETC failed";
+    printf "%s is number %d\n", "Perl", 1;
+}
+EXPECT
+This is a reversed sentence.
+-- Out of inspiration --
+foo->can(READ)(string 10 1)
+Don't GETC, Get Perl
+Perl is number 1
+and destroyed as well
+########
+my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"
+EXPECT
+2 2 2
+########
+# used to attach defelem magic to all immortal values,
+# which made restore of local $_ fail.
+foo(2>1);
+sub foo { bar() for @_;  }
+sub bar { local $_; }
+print "ok\n";
+EXPECT
+ok
+########
+@a = ($a, $b, $c, $d) = (5, 6);
+print "ok\n"
+  if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]);
+EXPECT
+ok
+########
+print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000);
+EXPECT
+ok
+########
+print "ok\n" if ("\0" lt "\xFF");
+EXPECT
+ok
+########
+open(H,$^O eq 'MacOS' ? ':run:fresh_perl.t' : 'run/fresh_perl.t'); # must be in the 't' directory
+stat(H);
+print "ok\n" if (-e _ and -f _ and -r _);
+EXPECT
+ok
+########
+sub thing { 0 || return qw(now is the time) }
+print thing(), "\n";
+EXPECT
+nowisthetime
+########
+$ren = 'joy';
+$stimpy = 'happy';
+{ local $main::{ren} = *stimpy; print $ren, ' ' }
+print $ren, "\n";
+EXPECT
+happy joy
+########
+$stimpy = 'happy';
+{ local $main::{ren} = *stimpy; print ${'ren'}, ' ' }
+print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n";
+EXPECT
+happy joy
+########
+package p;
+sub func { print 'really ' unless wantarray; 'p' }
+sub groovy { 'groovy' }
+package main;
+print p::func()->groovy(), "\n"
+EXPECT
+really groovy
+########
+@list = ([ 'one', 1 ], [ 'two', 2 ]);
+sub func { $num = shift; (grep $_->[1] == $num, @list)[0] }
+print scalar(map &func($_), 1 .. 3), " ",
+      scalar(map scalar &func($_), 1 .. 3), "\n";
+EXPECT
+2 3
+########
+($k, $s)  = qw(x 0);
+@{$h{$k}} = qw(1 2 4);
+for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) }
+print "bogus\n" unless $s == 7;
+########
+my $a = 'outer';
+eval q[ my $a = 'inner'; eval q[ print "$a " ] ];
+eval { my $x = 'peace'; eval q[ print "$x\n" ] }
+EXPECT
+inner peace
+########
+-w
+$| = 1;
+sub foo {
+    print "In foo1\n";
+    eval 'sub foo { print "In foo2\n" }';
+    print "Exiting foo1\n";
+}
+foo;
+foo;
+EXPECT
+In foo1
+Subroutine foo redefined at (eval 1) line 1.
+Exiting foo1
+In foo2
+########
+$s = 0;
+map {#this newline here tickles the bug
+$s += $_} (1,2,4);
+print "eat flaming death\n" unless ($s == 7);
+########
+sub foo { local $_ = shift; split; @_ }
+@x = foo(' x  y  z ');
+print "you die joe!\n" unless "@x" eq 'x y z';
+########
+/(?{"{"})/	# Check it outside of eval too
+EXPECT
+Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern
+Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1.
+########
+/(?{"{"}})/	# Check it outside of eval too
+EXPECT
+Unmatched right curly bracket at (re_eval 1) line 1, at end of line
+syntax error at (re_eval 1) line 1, near ""{"}"
+Compilation failed in regexp at - line 1.
+########
+BEGIN { @ARGV = qw(a b c d e) }
+BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" }
+END { print "end <",shift,">\nargv <@ARGV>\n" }
+INIT { print "init <",shift,">\n" }
+CHECK { print "check <",shift,">\n" }
+EXPECT
+argv <a b c d e>
+begin <a>
+check <b>
+init <c>
+end <d>
+argv <e>
+########
+-l
+# fdopen from a system descriptor to a system descriptor used to close
+# the former.
+open STDERR, '>&=STDOUT' or die $!;
+select STDOUT; $| = 1; print fileno STDOUT or die $!;
+select STDERR; $| = 1; print fileno STDERR or die $!;
+EXPECT
+1
+2
+########
+-w
+sub testme { my $a = "test"; { local $a = "new test"; print $a }}
+EXPECT
+Can't localize lexical variable $a at - line 2.
+########
+package X;
+sub ascalar { my $r; bless \$r }
+sub DESTROY { print "destroyed\n" };
+package main;
+*s = ascalar X;
+EXPECT
+destroyed
+########
+package X;
+sub anarray { bless [] }
+sub DESTROY { print "destroyed\n" };
+package main;
+*a = anarray X;
+EXPECT
+destroyed
+########
+package X;
+sub ahash { bless {} }
+sub DESTROY { print "destroyed\n" };
+package main;
+*h = ahash X;
+EXPECT
+destroyed
+########
+package X;
+sub aclosure { my $x; bless sub { ++$x } }
+sub DESTROY { print "destroyed\n" };
+package main;
+*c = aclosure X;
+EXPECT
+destroyed
+########
+package X;
+sub any { bless {} }
+my $f = "FH000"; # just to thwart any future optimisations
+sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r }
+sub DESTROY { print "destroyed\n" }
+package main;
+$x = any X; # to bump sv_objcount. IO objs aren't counted??
+*f = afh X;
+EXPECT
+destroyed
+destroyed
+########
+BEGIN {
+  $| = 1;
+  $SIG{__WARN__} = sub {
+    eval { print $_[0] };
+    die "bar\n";
+  };
+  warn "foo\n";
+}
+EXPECT
+foo
+bar
+BEGIN failed--compilation aborted at - line 8.
+########
+package X;
+@ISA='Y';
+sub new {
+    my $class = shift;
+    my $self = { };
+    bless $self, $class;
+    my $init = shift;
+    $self->foo($init);
+    print "new", $init;
+    return $self;
+}
+sub DESTROY {
+    my $self = shift;
+    print "DESTROY", $self->foo;
+}
+package Y;
+sub attribute {
+    my $self = shift;
+    my $var = shift;
+    if (@_ == 0) {
+	return $self->{$var};
+    } elsif (@_ == 1) {
+	$self->{$var} = shift;
+    }
+}
+sub AUTOLOAD {
+    $AUTOLOAD =~ /::([^:]+)$/;
+    my $method = $1;
+    splice @_, 1, 0, $method;
+    goto &attribute;
+}
+package main;
+my $x = X->new(1);
+for (2..3) {
+    my $y = X->new($_);
+    print $y->foo;
+}
+print $x->foo;
+EXPECT
+new1new22DESTROY2new33DESTROY31DESTROY1
+########
+re();
+sub re {
+    my $re = join '', eval 'qr/(??{ $obj->method })/';
+    $re;
+}
+EXPECT
+########
+use strict;
+my $foo = "ZZZ\n";
+END { print $foo }
+EXPECT
+ZZZ
+########
+eval '
+use strict;
+my $foo = "ZZZ\n";
+END { print $foo }
+';
+EXPECT
+ZZZ
+########
+-w
+if (@ARGV) { print "" }
+else {
+  if ($x == 0) { print "" } else { print $x }
+}
+EXPECT
+Use of uninitialized value in numeric eq (==) at - line 4.
+########
+$x = sub {};
+foo();
+sub foo { eval { return }; }
+print "ok\n";
+EXPECT
+ok
+########
+# moved to op/lc.t
+EXPECT
+########
+sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next }
+my $x = "foo";
+{ f } continue { print $x, "\n" }
+EXPECT
+foo
+########
+sub C () { 1 }
+sub M { $_[0] = 2; }
+eval "C";
+M(C);
+EXPECT
+Modification of a read-only value attempted at - line 2.
+########
+print qw(ab a\b a\\b);
+EXPECT
+aba\ba\b
+########
+# lexicals declared after the myeval() definition should not be visible
+# within it
+sub myeval { eval $_[0] }
+my $foo = "ok 2\n";
+myeval('sub foo { local $foo = "ok 1\n"; print $foo; }');
+die $@ if $@;
+foo();
+print $foo;
+EXPECT
+ok 1
+ok 2
+########
+# lexicals outside an eval"" should be visible inside subroutine definitions
+# within it
+eval <<'EOT'; die $@ if $@;
+{
+    my $X = "ok\n";
+    eval 'sub Y { print $X }'; die $@ if $@;
+    Y();
+}
+EOT
+EXPECT
+ok
+########
+# This test is here instead of lib/locale.t because
+# the bug depends on in the internal state of the locale
+# settings and pragma/locale messes up that state pretty badly.
+# We need a "fresh run".
+BEGIN {
+    eval { require POSIX };
+    if ($@) {
+	exit(0); # running minitest?
+    }
+}
+use Config;
+my $have_setlocale = $Config{d_setlocale} eq 'define';
+$have_setlocale = 0 if $@;
+# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
+# and mingw32 uses said silly CRT
+$have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i);
+exit(0) unless $have_setlocale;
+my @locales;
+if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) {
+    while(<LOCALES>) {
+        chomp;
+        push(@locales, $_);
+    }
+    close(LOCALES);
+}
+exit(0) unless @locales;
+for (@locales) {
+    use POSIX qw(locale_h);
+    use locale;
+    setlocale(LC_NUMERIC, $_) or next;
+    my $s = sprintf "%g %g", 3.1, 3.1;
+    next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/;
+    print "$_ $s\n";
+}
+EXPECT
+########
+die qr(x)
+EXPECT
+(?-xism:x) at - line 1.
+########
+# 20001210.003 mjd@plover.com
+format REMITOUT_TOP =
+FOO
+.
+
+format REMITOUT =
+BAR
+.
+
+# This loop causes a segv in 5.6.0
+for $lineno (1..61) {
+   write REMITOUT;
+}
+
+print "It's OK!";
+EXPECT
+It's OK!
+########
+# Inaba Hiroto
+reset;
+if (0) {
+  if ("" =~ //) {
+  }
+}
+########
+# Nicholas Clark
+$ENV{TERM} = 0;
+reset;
+// if 0;
+########
+# Vadim Konovalov
+use strict;
+sub new_pmop($) {
+    my $pm = shift;
+    return eval "sub {shift=~/$pm/}";
+}
+new_pmop "abcdef"; reset;
+new_pmop "abcdef"; reset;
+new_pmop "abcdef"; reset;
+new_pmop "abcdef"; reset;
+########
+# David Dyck
+# coredump in 5.7.1
+close STDERR; die;
+EXPECT
+########
+-w
+"x" =~ /(\G?x)?/;	# core dump in 20000716.007
+########
+# Bug 20010515.004
+my @h = 1 .. 10;
+bad(@h);
+sub bad {
+   undef @h;
+   print "O";
+   print for @_;
+   print "K";
+}
+EXPECT
+OK
+########
+# Bug 20010506.041
+"abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n";
+EXPECT
+ok
+########
+# Bug 20010422.005
+{s//${}/; //}
+EXPECT
+syntax error at - line 2, near "${}"
+Execution of - aborted due to compilation errors.
+########
+# Bug 20010528.007
+"\x{"
+EXPECT
+Missing right brace on \x{} at - line 2, within string
+Execution of - aborted due to compilation errors.
+########
+my $foo = Bar->new();
+my @dst;
+END {
+    ($_ = "@dst") =~ s/\(0x.+?\)/(0x...)/;
+    print $_, "\n";
+}
+package Bar;
+sub new {
+    my Bar $self = bless [], Bar;
+    eval '$self';
+    return $self;
+}
+sub DESTROY { 
+    push @dst, "$_[0]";
+}
+EXPECT
+Bar=ARRAY(0x...)
+########
+######## found by Markov chain stress testing
+eval "a.b.c.d.e.f;sub"
+EXPECT
+
+######## perlbug ID 20010831.001
+($a, b) = (1, 2);
+EXPECT
+Can't modify constant item in list assignment at - line 1, near ");"
+Execution of - aborted due to compilation errors.
+######## tying a bareword causes a segfault in 5.6.1
+tie FOO, "Foo";
+EXPECT
+Can't modify constant item in tie at - line 1, near ""Foo";"
+Execution of - aborted due to compilation errors.
+######## undefing constant causes a segfault in 5.6.1 [ID 20010906.019]
+undef foo;
+EXPECT
+Can't modify constant item in undef operator at - line 1, near "foo;"
+Execution of - aborted due to compilation errors.
+######## (?{...}) compilation bounces on PL_rs
+-0
+{
+  /(?{ $x })/;
+  # {
+}
+BEGIN { print "ok\n" }
+EXPECT
+ok
+######## read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054]
+read($bla, FILE, 1);
+EXPECT
+Can't modify constant item in read at - line 1, near "1)"
+Execution of - aborted due to compilation errors.
+######## scalar ref to file test operator segfaults on 5.6.1 [ID 20011127.155]
+# This only happens if the filename is 11 characters or less.
+$foo = \-f "blah";
+print "ok" if ref $foo && !$$foo;
+EXPECT
+ok
+######## [ID 20011128.159] 'X' =~ /\X/ segfault in 5.6.1
+print "ok" if 'X' =~ /\X/;
+EXPECT
+ok
+######## segfault in 5.6.1 within peep()
+@a = (1..9);
+@b = sort { @c = sort { @d = sort { 0 } @a; @d; } @a; } @a;
+print join '', @a, "\n";
+EXPECT
+123456789
+######## [ID 20020104.007] "coredump on dbmclose"
+package Foo;
+eval { require AnyDBM_File }; # not all places have dbm* functions
+if ($@) {
+    print "ok\n";
+    exit 0;
+}
+package Foo;
+sub new {
+        my $proto = shift;
+        my $class = ref($proto) || $proto;
+        my $self  = {};
+        bless($self,$class);
+        my %LT;
+        dbmopen(%LT, "dbmtest", 0666) ||
+	    die "Can't open dbmtest because of $!\n";
+        $self->{'LT'} = \%LT;
+        return $self;
+}
+sub DESTROY {
+        my $self = shift;
+	dbmclose(%{$self->{'LT'}});
+	1 while unlink 'dbmtest';
+	1 while unlink <dbmtest.*>;
+	print "ok\n";
+}
+package main;
+$test = Foo->new(); # must be package var
+EXPECT
+ok
+######## example from Camel 5, ch. 15, pp.406 (with my)
+# SKIP: ord "A" == 193 # EBCDIC
+use strict;
+use utf8;
+my $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
+$人++; # a child is born
+print $人, "\n";
+EXPECT
+3
+######## example from Camel 5, ch. 15, pp.406 (with our)
+# SKIP: ord "A" == 193 # EBCDIC
+use strict;
+use utf8;
+our $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
+$人++; # a child is born
+print $人, "\n";
+EXPECT
+3
+######## example from Camel 5, ch. 15, pp.406 (with package vars)
+# SKIP: ord "A" == 193 # EBCDIC
+use utf8;
+$人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
+$人++; # a child is born
+print $人, "\n";
+EXPECT
+3
+######## example from Camel 5, ch. 15, pp.406 (with use vars)
+# SKIP: ord "A" == 193 # EBCDIC
+use strict;
+use utf8;
+use vars qw($人);
+$人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
+$人++; # a child is born
+print $人, "\n";
+EXPECT
+3
+########
+# test that closures generated by eval"" hold on to the CV of the eval""
+# for their entire lifetime
+$code = eval q[
+  sub { eval '$x = "ok 1\n"'; }
+];
+&{$code}();
+print $x;
+EXPECT
+ok 1
+######## [ID 20020623.009] nested eval/sub segfaults
+$eval = eval 'sub { eval "sub { %S }" }';
+$eval->({});
diff --git a/gnu/usr.bin/perl/t/run/noswitch.t b/gnu/usr.bin/perl/t/run/noswitch.t
new file mode 100644
index 00000000000..a902c1fff7d
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/noswitch.t
@@ -0,0 +1,12 @@
+#!./perl
+
+BEGIN {
+    print "1..3\n";
+    *ARGV = *DATA;
+}
+print "ok 1\n";
+print <>;
+print "ok 3\n";
+
+__DATA__
+ok 2 - read from aliased DATA filehandle
diff --git a/gnu/usr.bin/perl/t/run/runenv.t b/gnu/usr.bin/perl/t/run/runenv.t
index a59ad26f35c..236f84eabb4 100644
--- a/gnu/usr.bin/perl/t/run/runenv.t
+++ b/gnu/usr.bin/perl/t/run/runenv.t
@@ -14,15 +14,17 @@ BEGIN {
     }
 }
 
+use Test;
+
+plan tests => 11;
+
 my $STDOUT = './results-0';
 my $STDERR = './results-1';
 my $PERL = './perl';
 my $FAILURE_CODE = 119;
 
-print "1..9\n";
-
 # Run perl with specified environment and arguments returns a list.
-# First element is true iff Perl's stdout and stderr match the
+# First element is true if Perl's stdout and stderr match the
 # supplied $stdout and $stderr argument strings exactly.
 # second element is an explanation of the failure
 sub runperl {
@@ -70,19 +72,14 @@ sub it_didnt_work {
 }
 
 sub try {
-  my $testno = shift;
   my ($success, $reason) = runperl(@_);
-  if ($success) {
-    print "ok $testno\n";
-  } else {
-    $reason =~ s/\n/\\n/g;
-    print "not ok $testno # $reason\n";    
-  }
+  $reason =~ s/\n/\\n/g if defined $reason;
+  ok( !!$success, 1, $reason );
 }
 
 #  PERL5OPT    Command-line options (switches).  Switches in
 #                    this variable are taken as if they were on
-#                    every Perl command line.  Only the -[DIMUdmw]
+#                    every Perl command line.  Only the -[DIMUdmtw]
 #                    switches are allowed.  When running taint
 #                    checks (because the program was running setuid
 #                    or setgid, or the -T switch was used), this
@@ -90,25 +87,24 @@ sub try {
 #                    -T, tainting will be enabled, and any
 #                    subsequent options ignored.
 
-my  $T = 1;
-try($T++, {PERL5OPT => '-w'}, ['-e', 'print $::x'],
+try({PERL5OPT => '-w'}, ['-e', 'print $::x'],
     "", 
     qq{Name "main::x" used only once: possible typo at -e line 1.\nUse of uninitialized value in print at -e line 1.\n});
 
-try($T++, {PERL5OPT => '-Mstrict'}, ['-e', 'print $::x'],
+try({PERL5OPT => '-Mstrict'}, ['-e', 'print $::x'],
     "", "");
 
-try($T++, {PERL5OPT => '-Mstrict'}, ['-e', 'print $x'],
+try({PERL5OPT => '-Mstrict'}, ['-e', 'print $x'],
     "", 
     qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
 
 # Fails in 5.6.0
-try($T++, {PERL5OPT => '-Mstrict -w'}, ['-e', 'print $x'],
+try({PERL5OPT => '-Mstrict -w'}, ['-e', 'print $x'],
     "", 
     qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
 
 # Fails in 5.6.0
-try($T++, {PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
+try({PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
     "", 
     <<ERROR
 Name "main::x" used only once: possible typo at -e line 1.
@@ -117,7 +113,7 @@ ERROR
     );
 
 # Fails in 5.6.0
-try($T++, {PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
+try({PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
     "", 
     <<ERROR
 Name "main::x" used only once: possible typo at -e line 1.
@@ -125,21 +121,29 @@ Use of uninitialized value in print at -e line 1.
 ERROR
     );
 
-try($T++, {PERL5OPT => '-MExporter'}, ['-e0'],
+try({PERL5OPT => '-MExporter'}, ['-e0'],
     "", 
     "");
 
 # Fails in 5.6.0
-try($T++, {PERL5OPT => '-MExporter -MExporter'}, ['-e0'],
+try({PERL5OPT => '-MExporter -MExporter'}, ['-e0'],
     "", 
     "");
 
-try($T++, {PERL5OPT => '-Mstrict -Mwarnings'}, 
+try({PERL5OPT => '-Mstrict -Mwarnings'}, 
     ['-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'],
     "ok",
     "");
 
-print "# ", $T-1, " tests total.\n";
+try({PERL5OPT => '-w -w'},
+    ['-e', 'print $ENV{PERL5OPT}'],
+    '-w -w',
+    '');
+
+try({PERL5OPT => '-t'},
+    ['-e', 'print ${^TAINT}'],
+    '1',
+    '');
 
 END {
     1 while unlink $STDOUT;
diff --git a/gnu/usr.bin/perl/t/run/switchF.t b/gnu/usr.bin/perl/t/run/switchF.t
new file mode 100644
index 00000000000..a6e9031d0c8
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/switchF.t
@@ -0,0 +1,11 @@
+#!./perl -anFx+
+
+BEGIN {
+    print "1..2\n";
+    *ARGV = *DATA;
+}
+print "@F";
+
+__DATA__
+okx1
+okxxx2
diff --git a/gnu/usr.bin/perl/t/run/switchPx.aux b/gnu/usr.bin/perl/t/run/switchPx.aux
new file mode 100644
index 00000000000..68ebc83f793
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/switchPx.aux
@@ -0,0 +1,34 @@
+Some stuff that's not Perl
+
+This CPP directive should not be read.
+#define BARMAR 1
+
+#perl
+
+Still not perl.
+
+#!
+
+still not perl
+
+#!/something/else
+
+still not perl
+
+#!/some/path/that/leads/to/perl -l
+
+# The -l switch should be applied from the #! line.
+# Unfortunately, -P has a bug whereby the #! line is ignored.
+# If this test suddenly starts printing blank lines that bug is fixed.
+
+#define FOO "ok 1\n"
+
+#ifdef BARMAR
+#   define YAR "not ok 2\n"
+#else
+#   define YAR "ok 2\n"
+#endif
+
+print "1..2\n";
+print FOO;
+print YAR;
diff --git a/gnu/usr.bin/perl/t/run/switchPx.t b/gnu/usr.bin/perl/t/run/switchPx.t
new file mode 100644
index 00000000000..72b068fe838
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/switchPx.t
@@ -0,0 +1,22 @@
+#!./perl
+
+# Ensure that the -P and -x flags work together.
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    $ENV{PERL5LIB} = '../lib';
+
+    use Config;
+    if ( $^O eq 'MacOS' || ($Config{'cppstdin'} =~ /\bcppstdin\b/) &&
+	 ! -x $Config{'binexp'} . "/cppstdin" ) {
+	print "1..0 # Skip: \$Config{cppstdin} unavailable\n";
+	    exit; 		# Cannot test till after install, alas.
+    }
+}
+
+require './test.pl';
+
+print runperl( switches => ['-Px'], 
+               nolib => 1,   # for some reason this is necessary under VMS
+               progfile => 'run/switchPx.aux' );
diff --git a/gnu/usr.bin/perl/t/run/switcha.t b/gnu/usr.bin/perl/t/run/switcha.t
new file mode 100644
index 00000000000..ec2f0ccc066
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/switcha.t
@@ -0,0 +1,12 @@
+#!./perl -na
+
+BEGIN {
+    print "1..2\n";
+    *ARGV = *DATA;
+    $i = 0;
+}
+print "$F[1] ",++$i,"\n";
+
+__DATA__
+not ok
+not ok 3
diff --git a/gnu/usr.bin/perl/t/run/switches.t b/gnu/usr.bin/perl/t/run/switches.t
new file mode 100644
index 00000000000..996ad5d4c64
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/switches.t
@@ -0,0 +1,202 @@
+#!./perl -w
+
+# Tests for the command-line switches
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+require "./test.pl";
+
+plan(tests => 19);
+
+# due to a bug in VMS's piping which makes it impossible for runperl()
+# to emulate echo -n (ie. stdin always winds up with a newline), these 
+# tests almost totally fail.
+$TODO = "runperl() unable to emulate echo -n due to pipe bug" if $^O eq 'VMS';
+
+my $r;
+my @tmpfiles = ();
+END { unlink @tmpfiles }
+
+# Tests for -0
+
+$r = runperl(
+    switches	=> [ '-0', ],
+    stdin	=> 'foo\0bar\0baz\0',
+    prog	=> 'print qq(<$_>) while <>',
+);
+is( $r, "<foo\0><bar\0><baz\0>", "-0" );
+
+$r = runperl(
+    switches	=> [ '-l', '-0', '-p' ],
+    stdin	=> 'foo\0bar\0baz\0',
+    prog	=> '1',
+);
+is( $r, "foo\nbar\nbaz\n", "-0 after a -l" );
+
+$r = runperl(
+    switches	=> [ '-0', '-l', '-p' ],
+    stdin	=> 'foo\0bar\0baz\0',
+    prog	=> '1',
+);
+is( $r, "foo\0bar\0baz\0", "-0 before a -l" );
+
+$r = runperl(
+    switches	=> [ sprintf("-0%o", ord 'x') ],
+    stdin	=> 'fooxbarxbazx',
+    prog	=> 'print qq(<$_>) while <>',
+);
+is( $r, "<foox><barx><bazx>", "-0 with octal number" );
+
+$r = runperl(
+    switches	=> [ '-00', '-p' ],
+    stdin	=> 'abc\ndef\n\nghi\njkl\nmno\n\npq\n',
+    prog	=> 's/\n/-/g;$_.=q(/)',
+);
+is( $r, 'abc-def--/ghi-jkl-mno--/pq-/', '-00 (paragraph mode)' );
+
+$r = runperl(
+    switches	=> [ '-0777', '-p' ],
+    stdin	=> 'abc\ndef\n\nghi\njkl\nmno\n\npq\n',
+    prog	=> 's/\n/-/g;$_.=q(/)',
+);
+is( $r, 'abc-def--ghi-jkl-mno--pq-/', '-0777 (slurp mode)' );
+
+# Tests for -c
+
+my $filename = 'swctest.tmp';
+SKIP: {
+    local $TODO = '';   # this one works on VMS
+
+    open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" );
+    print $f <<'SWTEST';
+BEGIN { print "block 1\n"; }
+CHECK { print "block 2\n"; }
+INIT  { print "block 3\n"; }
+	print "block 4\n";
+END   { print "block 5\n"; }
+SWTEST
+    close $f or die "Could not close: $!";
+    $r = runperl(
+	switches	=> [ '-c' ],
+	progfile	=> $filename,
+	stderr		=> 1,
+    );
+    # Because of the stderr redirection, we can't tell reliably the order
+    # in which the output is given
+    ok(
+	$r =~ /$filename syntax OK/
+	&& $r =~ /\bblock 1\b/
+	&& $r =~ /\bblock 2\b/
+	&& $r !~ /\bblock 3\b/
+	&& $r !~ /\bblock 4\b/
+	&& $r !~ /\bblock 5\b/,
+	'-c'
+    );
+    push @tmpfiles, $filename;
+}
+
+# Tests for -l
+
+$r = runperl(
+    switches	=> [ sprintf("-l%o", ord 'x') ],
+    prog	=> 'print for qw/foo bar/'
+);
+is( $r, 'fooxbarx', '-l with octal number' );
+
+# Tests for -s
+
+$r = runperl(
+    switches	=> [ '-s' ],
+    prog	=> 'for (qw/abc def ghi/) {print defined $$_ ? $$_ : q(-)}',
+    args	=> [ '--', '-abc=2', '-def', ],
+);
+is( $r, '21-', '-s switch parsing' );
+
+# Bug ID 20011106.084
+$filename = 'swstest.tmp';
+SKIP: {
+    open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" );
+    print $f <<'SWTEST';
+#!perl -s
+print $x
+SWTEST
+    close $f or die "Could not close: $!";
+    $r = runperl(
+	switches    => [ '-s' ],
+	progfile    => $filename,
+	args	    => [ '-x=foo' ],
+    );
+    is( $r, 'foo', '-s on the shebang line' );
+    push @tmpfiles, $filename;
+}
+
+# Tests for -m and -M
+
+$filename = 'swtest.pm';
+SKIP: {
+    open my $f, ">$filename" or skip( "Can't write temp file $filename: $!",4 );
+    print $f <<'SWTESTPM';
+package swtest;
+sub import { print map "<$_>", @_ }
+1;
+SWTESTPM
+    close $f or die "Could not close: $!";
+    $r = runperl(
+	switches    => [ '-Mswtest' ],
+	prog	    => '1',
+    );
+    is( $r, '<swtest>', '-M' );
+    $r = runperl(
+	switches    => [ '-Mswtest=foo' ],
+	prog	    => '1',
+    );
+    is( $r, '<swtest><foo>', '-M with import parameter' );
+    $r = runperl(
+	switches    => [ '-mswtest' ],
+	prog	    => '1',
+    );
+
+    {
+        local $TODO = '';  # this one works on VMS
+        is( $r, '', '-m' );
+    }
+    $r = runperl(
+	switches    => [ '-mswtest=foo,bar' ],
+	prog	    => '1',
+    );
+    is( $r, '<swtest><foo><bar>', '-m with import parameters' );
+    push @tmpfiles, $filename;
+}
+
+# Tests for -V
+
+{
+    local $TODO = '';   # these ones should work on VMS
+
+    # basic perl -V should generate significant output.
+    # we don't test actual format since it could change
+    like( runperl( switches => ['-V'] ), qr/(\n.*){20}/,
+          '-V generates 20+ lines' );
+
+    # lookup a known config var
+    chomp( $r=runperl( switches => ['-V:osname'] ) );
+    is( $r, "osname='$^O';", 'perl -V:osname');
+
+    # lookup a nonexistent var
+    chomp( $r=runperl( switches => ['-V:this_var_makes_switches_test_fail'] ) );
+    is( $r, "this_var_makes_switches_test_fail='UNKNOWN';",
+        'perl -V:unknown var');
+
+    # regexp lookup
+    # platforms that don't like this quoting can either skip this test
+    # or fix test.pl _quote_args
+    $r = runperl( switches => ['"-V:i\D+size"'] );
+    # should be unlike( $r, qr/^$|not found|UNKNOWN/ );
+    like( $r, qr/^(?!.*(not found|UNKNOWN))./, 'perl -V:re got a result' );
+
+    # make sure each line we got matches the re
+    ok( !( grep !/^i\D+size=/, split /^/, $r ), '-V:re correct' );
+}
diff --git a/gnu/usr.bin/perl/t/run/switchn.t b/gnu/usr.bin/perl/t/run/switchn.t
new file mode 100644
index 00000000000..12d3898a8ed
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/switchn.t
@@ -0,0 +1,11 @@
+#!./perl -n
+
+BEGIN {
+    print "1..2\n";
+    *ARGV = *DATA;
+}
+print;
+
+__DATA__
+ok 1
+ok 2
diff --git a/gnu/usr.bin/perl/t/run/switchp.t b/gnu/usr.bin/perl/t/run/switchp.t
new file mode 100644
index 00000000000..19947356d9b
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/switchp.t
@@ -0,0 +1,10 @@
+#!./perl -p
+
+BEGIN {
+    print "1..2\n";
+    *ARGV = *DATA;
+}
+
+__DATA__
+ok 1
+ok 2
diff --git a/gnu/usr.bin/perl/t/run/switcht.t b/gnu/usr.bin/perl/t/run/switcht.t
new file mode 100644
index 00000000000..869605ff953
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/switcht.t
@@ -0,0 +1,45 @@
+#!./perl -t
+
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+plan tests => 11;
+
+my $Perl = which_perl();
+
+my $warning;
+local $SIG{__WARN__} = sub { $warning = join "\n", @_; };
+my $Tmsg = 'while running with -t switch';
+
+ok( ${^TAINT},      '${^TAINT} defined' );
+
+my $out = `$Perl -le "print q(Hello)"`;
+is( $out, "Hello\n",                      '`` worked' );
+like( $warning, qr/^Insecure .* $Tmsg/, '    taint warn' );
+
+{
+    no warnings 'taint';
+    $warning = '';
+    my $out = `$Perl -le "print q(Hello)"`;
+    is( $out, "Hello\n",                      '`` worked' );
+    is( $warning, '',                       '   no warnings "taint"' );
+}
+
+# Get ourselves a tainted variable.
+$file = $0;
+$file =~ s/.*/some.tmp/;
+ok( open(FILE, ">$file"),   'open >' ) or DIE $!;
+print FILE "Stuff\n";
+close FILE;
+like( $warning, qr/^Insecure dependency in open $Tmsg/, 'open > taint warn' );
+ok( -e $file,   '   file written' );
+
+unlink($file);
+like( $warning, qr/^Insecure dependency in unlink $Tmsg/,
+                                                  'unlink() taint warn' );
+ok( !-e $file,  'unlink worked' );
+
+ok( !$^W,   "-t doesn't enable regular warnings" );
diff --git a/gnu/usr.bin/perl/t/run/switchx.aux b/gnu/usr.bin/perl/t/run/switchx.aux
new file mode 100644
index 00000000000..576730c80a4
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/switchx.aux
@@ -0,0 +1,21 @@
+Some stuff that's not Perl
+
+This CPP directive should not be read.
+#define BARMAR 1
+
+#perl
+
+Still not perl.
+
+#!
+
+still not perl
+
+#!/something/else
+
+still not perl
+
+#!/some/path/that/leads/to/perl -l
+
+print "1..1";
+print "ok 1";
diff --git a/gnu/usr.bin/perl/t/run/switchx.t b/gnu/usr.bin/perl/t/run/switchx.t
new file mode 100644
index 00000000000..60a522cf491
--- /dev/null
+++ b/gnu/usr.bin/perl/t/run/switchx.t
@@ -0,0 +1,11 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+require './test.pl';
+use File::Spec::Functions;
+
+print runperl( switches => ['-x'], progfile => catfile(curdir(), 'run', 'switchx.aux') );
diff --git a/gnu/usr.bin/perl/t/test.pl b/gnu/usr.bin/perl/t/test.pl
new file mode 100644
index 00000000000..427a64f5786
--- /dev/null
+++ b/gnu/usr.bin/perl/t/test.pl
@@ -0,0 +1,585 @@
+#
+# t/test.pl - most of Test::More functionality without the fuss
+#
+
+my $test = 1;
+my $planned;
+
+$TODO = 0;
+$NO_ENDING = 0;
+
+sub plan {
+    my $n;
+    if (@_ == 1) {
+	$n = shift;
+    } else {
+	my %plan = @_;
+	$n = $plan{tests}; 
+    }
+    print STDOUT "1..$n\n";
+    $planned = $n;
+}
+
+END {
+    my $ran = $test - 1;
+    if (!$NO_ENDING && defined $planned && $planned != $ran) {
+        print STDERR "# Looks like you planned $planned tests but ran $ran.\n";
+    }
+}
+
+# Use this instead of "print STDERR" when outputing failure diagnostic 
+# messages
+sub _diag {
+    return unless @_;
+    my @mess = map { /^#/ ? "$_\n" : "# $_\n" } 
+               map { split /\n/ } @_;
+    my $fh = $TODO ? *STDOUT : *STDERR;
+    print $fh @mess;
+
+}
+
+sub skip_all {
+    if (@_) {
+	print STDOUT "1..0 # Skipped: @_\n";
+    } else {
+	print STDOUT "1..0\n";
+    }
+    exit(0);
+}
+
+sub _ok {
+    my ($pass, $where, $name, @mess) = @_;
+    # Do not try to microoptimize by factoring out the "not ".
+    # VMS will avenge.
+    my $out;
+    if ($name) {
+        # escape out '#' or it will interfere with '# skip' and such
+        $name =~ s/#/\\#/g;
+	$out = $pass ? "ok $test - $name" : "not ok $test - $name";
+    } else {
+	$out = $pass ? "ok $test" : "not ok $test";
+    }
+
+    $out .= " # TODO $TODO" if $TODO;
+    print STDOUT "$out\n";
+
+    unless ($pass) {
+	_diag "# Failed $where\n";
+    }
+
+    # Ensure that the message is properly escaped.
+    _diag @mess;
+
+    $test++;
+
+    return $pass;
+}
+
+sub _where {
+    my @caller = caller(1);
+    return "at $caller[1] line $caller[2]";
+}
+
+# DON'T use this for matches. Use like() instead.
+sub ok {
+    my ($pass, $name, @mess) = @_;
+    _ok($pass, _where(), $name, @mess);
+}
+
+sub _q {
+    my $x = shift;
+    return 'undef' unless defined $x;
+    my $q = $x;
+    $q =~ s/\\/\\\\/;
+    $q =~ s/'/\\'/;
+    return "'$q'";
+}
+
+sub _qq {
+    my $x = shift;
+    return defined $x ? '"' . display ($x) . '"' : 'undef';
+};
+
+# keys are the codes \n etc map to, values are 2 char strings such as \n
+my %backslash_escape;
+foreach my $x (split //, 'nrtfa\\\'"') {
+    $backslash_escape{ord eval "\"\\$x\""} = "\\$x";
+}
+# A way to display scalars containing control characters and Unicode.
+# Trying to avoid setting $_, or relying on local $_ to work.
+sub display {
+    my @result;
+    foreach my $x (@_) {
+        if (defined $x and not ref $x) {
+            my $y = '';
+            foreach my $c (unpack("U*", $x)) {
+                if ($c > 255) {
+                    $y .= sprintf "\\x{%x}", $c;
+                } elsif ($backslash_escape{$c}) {
+                    $y .= $backslash_escape{$c};
+                } else {
+                    my $z = chr $c; # Maybe we can get away with a literal...
+                    $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/;
+                    $y .= $z;
+                }
+            }
+            $x = $y;
+        }
+        return $x unless wantarray;
+        push @result, $x;
+    }
+    return @result;
+}
+
+sub is {
+    my ($got, $expected, $name, @mess) = @_;
+    my $pass = $got eq $expected;
+    unless ($pass) {
+	unshift(@mess, "#      got "._q($got)."\n",
+		       "# expected "._q($expected)."\n");
+    }
+    _ok($pass, _where(), $name, @mess);
+}
+
+sub isnt {
+    my ($got, $isnt, $name, @mess) = @_;
+    my $pass = $got ne $isnt;
+    unless( $pass ) {
+        unshift(@mess, "# it should not be "._q($got)."\n",
+                       "# but it is.\n");
+    }
+    _ok($pass, _where(), $name, @mess);
+}
+
+sub cmp_ok {
+    my($got, $type, $expected, $name, @mess) = @_;
+
+    my $pass;
+    {
+        local $^W = 0;
+        local($@,$!);   # don't interfere with $@
+                        # eval() sometimes resets $!
+        $pass = eval "\$got $type \$expected";
+    }
+    unless ($pass) {
+        # It seems Irix long doubles can have 2147483648 and 2147483648
+        # that stringify to the same thing but are acutally numerically
+        # different. Display the numbers if $type isn't a string operator,
+        # and the numbers are stringwise the same.
+        # (all string operators have alphabetic names, so tr/a-z// is true)
+        # This will also show numbers for some uneeded cases, but will
+        # definately be helpful for things such as == and <= that fail
+        if ($got eq $expected and $type !~ tr/a-z//) {
+            unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
+        }
+        unshift(@mess, "#      got "._q($got)."\n",
+                       "# expected $type "._q($expected)."\n");
+    }
+    _ok($pass, _where(), $name, @mess);
+}
+
+# Check that $got is within $range of $expected
+# if $range is 0, then check it's exact
+# else if $expected is 0, then $range is an absolute value
+# otherwise $range is a fractional error.
+# Here $range must be numeric, >= 0
+# Non numeric ranges might be a useful future extension. (eg %)
+sub within {
+    my ($got, $expected, $range, $name, @mess) = @_;
+    my $pass;
+    if (!defined $got or !defined $expected or !defined $range) {
+        # This is a fail, but doesn't need extra diagnostics
+    } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) {
+        # This is a fail
+        unshift @mess, "# got, expected and range must be numeric\n";
+    } elsif ($range < 0) {
+        # This is also a fail
+        unshift @mess, "# range must not be negative\n";
+    } elsif ($range == 0) {
+        # Within 0 is ==
+        $pass = $got == $expected;
+    } elsif ($expected == 0) {
+        # If expected is 0, treat range as absolute
+        $pass = ($got <= $range) && ($got >= - $range);
+    } else {
+        my $diff = $got - $expected;
+        $pass = abs ($diff / $expected) < $range;
+    }
+    unless ($pass) {
+        if ($got eq $expected) {
+            unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
+        }
+	unshift@mess, "#      got "._q($got)."\n",
+		      "# expected "._q($expected)." (within "._q($range).")\n";
+    }
+    _ok($pass, _where(), $name, @mess);
+}
+
+# Note: this isn't quite as fancy as Test::More::like().
+sub like {
+    my ($got, $expected, $name, @mess) = @_;
+    my $pass;
+    if (ref $expected eq 'Regexp') {
+	$pass = $got =~ $expected;
+	unless ($pass) {
+	    unshift(@mess, "#      got '$got'\n",
+		           "# expected /$expected/\n");
+	}
+    } else {
+	$pass = $got =~ /$expected/;
+	unless ($pass) {
+	    unshift(@mess, "#      got '$got'\n",
+		           "# expected /$expected/\n");
+	}
+    }
+    _ok($pass, _where(), $name, @mess);
+}
+
+sub pass {
+    _ok(1, '', @_);
+}
+
+sub fail {
+    _ok(0, _where(), @_);
+}
+
+sub curr_test {
+    $test = shift if @_;
+    return $test;
+}
+
+sub next_test {
+  $test++;
+}
+
+# Note: can't pass multipart messages since we try to
+# be compatible with Test::More::skip().
+sub skip {
+    my $why = shift;
+    my $n    = @_ ? shift : 1;
+    for (1..$n) {
+        print STDOUT "ok $test # skip: $why\n";
+        $test++;
+    }
+    local $^W = 0;
+    last SKIP;
+}
+
+sub eq_array {
+    my ($ra, $rb) = @_;
+    return 0 unless $#$ra == $#$rb;
+    for my $i (0..$#$ra) {
+	return 0 unless $ra->[$i] eq $rb->[$i];
+    }
+    return 1;
+}
+
+sub eq_hash {
+  my ($orig, $suspect) = @_;
+  my $fail;
+  while (my ($key, $value) = each %$suspect) {
+    # Force a hash recompute if this perl's internals can cache the hash key.
+    $key = "" . $key;
+    if (exists $orig->{$key}) {
+      if ($orig->{$key} ne $value) {
+        print STDOUT "# key ", _qq($key), " was ", _qq($orig->{$key}),
+                     " now ", _qq($value), "\n";
+        $fail = 1;
+      }
+    } else {
+      print STDOUT "# key ", _qq($key), " is ", _qq($value), 
+                   ", not in original.\n";
+      $fail = 1;
+    }
+  }
+  foreach (keys %$orig) {
+    # Force a hash recompute if this perl's internals can cache the hash key.
+    $_ = "" . $_;
+    next if (exists $suspect->{$_});
+    print STDOUT "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
+    $fail = 1;
+  }
+  !$fail;
+}
+
+sub require_ok {
+    my ($require) = @_;
+    eval <<REQUIRE_OK;
+require $require;
+REQUIRE_OK
+    _ok(!$@, _where(), "require $require");
+}
+
+sub use_ok {
+    my ($use) = @_;
+    eval <<USE_OK;
+use $use;
+USE_OK
+    _ok(!$@, _where(), "use $use");
+}
+
+# runperl - Runs a separate perl interpreter.
+# Arguments :
+#   switches => [ command-line switches ]
+#   nolib    => 1 # don't use -I../lib (included by default)
+#   prog     => one-liner (avoid quotes)
+#   progs    => [ multi-liner (avoid quotes) ]
+#   progfile => perl script
+#   stdin    => string to feed the stdin
+#   stderr   => redirect stderr to stdout
+#   args     => [ command-line arguments to the perl program ]
+#   verbose  => print the command line
+
+my $is_mswin    = $^O eq 'MSWin32';
+my $is_netware  = $^O eq 'NetWare';
+my $is_macos    = $^O eq 'MacOS';
+my $is_vms      = $^O eq 'VMS';
+
+sub _quote_args {
+    my ($runperl, $args) = @_;
+
+    foreach (@$args) {
+	# In VMS protect with doublequotes because otherwise
+	# DCL will lowercase -- unless already doublequoted.
+       $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0;
+	$$runperl .= ' ' . $_;
+    }
+}
+
+sub runperl {
+    my %args = @_;
+    my $runperl = $^X;
+    unless ($args{nolib}) {
+	if ($is_macos) {
+	    $runperl .= ' -I::lib';
+	    # Use UNIX style error messages instead of MPW style.
+	    $runperl .= ' -MMac::err=unix' if $args{stderr};
+	}
+	else {
+	    $runperl .= ' "-I../lib"'; # doublequotes because of VMS
+	}
+    }
+    if ($args{switches}) {
+	_quote_args(\$runperl, $args{switches});
+    }
+    if (defined $args{prog}) {
+        $args{progs} = [$args{prog}]
+    }
+    if (defined $args{progs}) {
+        foreach my $prog (@{$args{progs}}) {
+            if ($is_mswin || $is_netware || $is_vms) {
+                $runperl .= qq ( -e "$prog" );
+            }
+            else {
+                $runperl .= qq ( -e '$prog' );
+            }
+        }
+    } elsif (defined $args{progfile}) {
+	$runperl .= qq( "$args{progfile}");
+    }
+    if (defined $args{stdin}) {
+	# so we don't try to put literal newlines and crs onto the
+	# command line.
+	$args{stdin} =~ s/\n/\\n/g;
+	$args{stdin} =~ s/\r/\\r/g;
+
+	if ($is_mswin || $is_netware || $is_vms) {
+	    $runperl = qq{$^X -e "print qq(} .
+		$args{stdin} . q{)" | } . $runperl;
+	}
+	elsif ($is_macos) {
+	    # MacOS can only do two processes under MPW at once;
+	    # the test itself is one; we can't do two more, so
+	    # write to temp file
+	    my $stdin = qq{$^X -e 'print qq(} . $args{stdin} . qq{)' > teststdin; };
+	    if ($args{verbose}) {
+		my $stdindisplay = $stdin;
+		$stdindisplay =~ s/\n/\n\#/g;
+		print STDERR "# $stdindisplay\n";
+	    }
+	    `$stdin`;
+	    $runperl .= q{ < teststdin };
+	}
+	else {
+	    $runperl = qq{$^X -e 'print qq(} .
+		$args{stdin} . q{)' | } . $runperl;
+	}
+    }
+    if (defined $args{args}) {
+	_quote_args(\$runperl, $args{args});
+    }
+    $runperl .= ' 2>&1'          if  $args{stderr} && !$is_macos;
+    $runperl .= " \xB3 Dev:Null" if !$args{stderr} &&  $is_macos;
+    if ($args{verbose}) {
+	my $runperldisplay = $runperl;
+	$runperldisplay =~ s/\n/\n\#/g;
+	print STDERR "# $runperldisplay\n";
+    }
+    my $result = `$runperl`;
+    $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
+    return $result;
+}
+
+*run_perl = \&runperl; # Nice alias.
+
+sub DIE {
+    print STDERR "# @_\n";
+    exit 1;
+}
+
+# A somewhat safer version of the sometimes wrong $^X.
+my $Perl;
+sub which_perl {
+    unless (defined $Perl) {
+	$Perl = $^X;
+	
+	# VMS should have 'perl' aliased properly
+	return $Perl if $^O eq 'VMS';
+
+	my $exe;
+	eval "require Config; Config->import";
+	if ($@) {
+	    warn "test.pl had problems loading Config: $@";
+	    $exe = '';
+	} else {
+	    $exe = $Config{_exe};
+	}
+       $exe = '' unless defined $exe;
+	
+	# This doesn't absolutize the path: beware of future chdirs().
+	# We could do File::Spec->abs2rel() but that does getcwd()s,
+	# which is a bit heavyweight to do here.
+	
+	if ($Perl =~ /^perl\Q$exe\E$/i) {
+	    my $perl = "perl$exe";
+	    eval "require File::Spec";
+	    if ($@) {
+		warn "test.pl had problems loading File::Spec: $@";
+		$Perl = "./$perl";
+	    } else {
+		$Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
+	    }
+	}
+
+	# Build up the name of the executable file from the name of
+	# the command.
+
+	if ($Perl !~ /\Q$exe\E$/i) {
+	    $Perl .= $exe;
+	}
+
+	warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
+	
+	# For subcommands to use.
+	$ENV{PERLEXE} = $Perl;
+    }
+    return $Perl;
+}
+
+sub unlink_all {
+    foreach my $file (@_) {
+        1 while unlink $file;
+        print STDERR "# Couldn't unlink '$file': $!\n" if -f $file;
+    }
+}
+
+
+my $tmpfile = "misctmp000";
+1 while -f ++$tmpfile;
+END { unlink_all $tmpfile }
+
+#
+# _fresh_perl
+#
+# The $resolve must be a subref that tests the first argument
+# for success, or returns the definition of success (e.g. the
+# expected scalar) if given no arguments.
+#
+
+sub _fresh_perl {
+    my($prog, $resolve, $runperl_args, $name) = @_;
+
+    $runperl_args ||= {};
+    $runperl_args->{progfile} = $tmpfile;
+    $runperl_args->{stderr} = 1;
+
+    open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
+
+    # VMS adjustments
+    if( $^O eq 'VMS' ) {
+        $prog =~ s#/dev/null#NL:#;
+
+        # VMS file locking 
+        $prog =~ s{if \(-e _ and -f _ and -r _\)}
+                  {if (-e _ and -f _)}
+    }
+
+    print TEST $prog, "\n";
+    close TEST or die "Cannot close $tmpfile: $!";
+
+    my $results = runperl(%$runperl_args);
+    my $status = $?;
+
+    # Clean up the results into something a bit more predictable.
+    $results =~ s/\n+$//;
+    $results =~ s/at\s+misctmp\d+\s+line/at - line/g;
+    $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g;
+
+    # bison says 'parse error' instead of 'syntax error',
+    # various yaccs may or may not capitalize 'syntax'.
+    $results =~ s/^(syntax|parse) error/syntax error/mig;
+
+    if ($^O eq 'VMS') {
+        # some tests will trigger VMS messages that won't be expected
+        $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
+
+        # pipes double these sometimes
+        $results =~ s/\n\n/\n/g;
+    }
+
+    my $pass = $resolve->($results);
+    unless ($pass) {
+        _diag "# PROG: \n$prog\n";
+        _diag "# EXPECTED:\n", $resolve->(), "\n";
+        _diag "# GOT:\n$results\n";
+        _diag "# STATUS: $status\n";
+    }
+
+    # Use the first line of the program as a name if none was given
+    unless( $name ) {
+        ($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
+        $name .= '...' if length $first_line > length $name;
+    }
+
+    _ok($pass, _where(), "fresh_perl - $name");
+}
+
+#
+# run_perl_is
+#
+# Combination of run_perl() and is().
+#
+
+sub fresh_perl_is {
+    my($prog, $expected, $runperl_args, $name) = @_;
+    _fresh_perl($prog,
+		sub { @_ ? $_[0] eq $expected : $expected },
+		$runperl_args, $name);
+}
+
+#
+# run_perl_like
+#
+# Combination of run_perl() and like().
+#
+
+sub fresh_perl_like {
+    my($prog, $expected, $runperl_args, $name) = @_;
+    _fresh_perl($prog,
+		sub { @_ ?
+			  $_[0] =~ (ref $expected ? $expected : /$expected/) :
+		          $expected },
+		$runperl_args, $name);
+}
+
+1;
diff --git a/gnu/usr.bin/perl/t/uni/case.pl b/gnu/usr.bin/perl/t/uni/case.pl
new file mode 100644
index 00000000000..b6df5a8089b
--- /dev/null
+++ b/gnu/usr.bin/perl/t/uni/case.pl
@@ -0,0 +1,134 @@
+use File::Spec;
+
+require "test.pl";
+
+sub unidump {
+    join " ", map { sprintf "%04X", $_ } unpack "U*", $_[0];
+}
+
+sub casetest {
+    my ($base, $spec, $func) = @_;
+    my $file = File::Spec->catfile(File::Spec->catdir(File::Spec->updir,
+						      "lib", "unicore", "To"),
+				   "$base.pl");
+    my $simple = do $file;
+    my %simple;
+    for my $i (split(/\n/, $simple)) {
+	my ($k, $v) = split(' ', $i);
+	$simple{$k} = $v;
+    }
+    my %seen;
+
+    for my $i (sort keys %simple) {
+	$seen{hex $i}++;
+    }
+    print "# ", scalar keys %simple, " simple mappings\n";
+
+    my $both;
+
+    for my $i (sort keys %$spec) {
+	if (++$seen{hex $i} == 2) {
+	    warn "$base: $i seen twice\n";
+	    $both++;
+	}
+    }
+    print "# ", scalar keys %$spec, " special mappings\n";
+
+    exit(1) if $both;
+
+    my %none;
+    for my $i (map { ord } split //,
+	       "\e !\"#\$%&'()+,-./0123456789:;<=>?\@[\\]^_{|}~\b") {
+	next if pack("U0U", $i) =~ /\w/;
+	$none{$i}++ unless $seen{$i};
+    }
+    print "# ", scalar keys %none, " noncase mappings\n";
+
+    my $tests = 
+	(scalar keys %simple) +
+	(scalar keys %$spec) +
+	(scalar keys %none);
+    print "1..$tests\n";
+
+    my $test = 1;
+
+    for my $i (sort { hex $a <=> hex $b } keys %simple) {
+	my $w = $simple{$i};
+	my $c = pack "U0U", hex $i;
+	my $d = $func->($c);
+	my $e = unidump($d);
+	print $d eq pack("U0U", hex $simple{$i}) ?
+	    "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n";
+	$test++;
+    }
+
+    for my $i (sort { hex $a <=> hex $b } keys %$spec) {
+	my $w = unidump($spec->{$i});
+	my $c = pack "U0U", hex $i;
+	my $d = $func->($c);
+	my $e = unidump($d);
+	if (ord "A" == 193) { # EBCDIC
+	    # We need to a little bit of remapping.
+	    #
+	    # For example, in titlecase (ucfirst) mapping
+	    # of U+0149 the Unicode mapping is U+02BC U+004E.
+	    # The 4E is N, which in EBCDIC is 2B--
+	    # and the ucfirst() does that right.
+	    # The problem is that our reference
+	    # data is in Unicode code points.
+	    #
+	    # The Right Way here would be to use, say,
+	    # Encode, to remap the less-than 0x100 code points,
+	    # but let's try to be Encode-independent here. 
+	    #
+	    # These are the titlecase exceptions:
+	    #
+	    #         Unicode   Unicode+EBCDIC  
+	    #
+	    # 0149 -> 02BC 004E (02BC 002B)
+	    # 01F0 -> 004A 030C (00A2 030C)
+	    # 1E96 -> 0048 0331 (00E7 0331)
+	    # 1E97 -> 0054 0308 (00E8 0308)
+	    # 1E98 -> 0057 030A (00EF 030A)
+	    # 1E99 -> 0059 030A (00DF 030A)
+	    # 1E9A -> 0041 02BE (00A0 02BE)
+	    #
+	    # The uppercase exceptions are identical.
+	    #
+	    # The lowercase has one more:
+	    #
+	    #         Unicode   Unicode+EBCDIC  
+	    #
+	    # 0130 -> 0069 0307 (00D1 0307)
+	    #
+	    if ($i =~ /^(0130|0149|01F0|1E96|1E97|1E98|1E99|1E9A)$/) {
+		$e =~ s/004E/002B/; # N
+		$e =~ s/004A/00A2/; # J
+		$e =~ s/0048/00E7/; # H
+		$e =~ s/0054/00E8/; # T
+		$e =~ s/0057/00EF/; # W
+		$e =~ s/0059/00DF/; # Y
+		$e =~ s/0041/00A0/; # A
+		$e =~ s/0069/00D1/; # i
+	    }
+	    # We have to map the output, not the input, because
+	    # pack/unpack U has been EBCDICified, too, it would
+	    # just undo our remapping.
+	}
+	print $w eq $e ?
+	    "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n";
+	$test++;
+    }
+
+    for my $i (sort { $a <=> $b } keys %none) {
+	my $w = $i = sprintf "%04X", $i;
+	my $c = pack "U0U", hex $i;
+	my $d = $func->($c);
+	my $e = unidump($d);
+	print $d eq $c ?
+	    "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n";
+	$test++;
+    }
+}
+
+1;
diff --git a/gnu/usr.bin/perl/t/uni/fold.t b/gnu/usr.bin/perl/t/uni/fold.t
new file mode 100644
index 00000000000..789ba670293
--- /dev/null
+++ b/gnu/usr.bin/perl/t/uni/fold.t
@@ -0,0 +1,51 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use File::Spec;
+
+my $CF = File::Spec->catfile(File::Spec->catdir(File::Spec->updir,
+					       "lib", "unicore"),
+			    "CaseFolding.txt");
+
+use constant EBCDIC => ord 'A' == 193;
+
+if (open(CF, $CF)) {
+    my @CF;
+
+    while (<CF>) {
+	# Skip S since we are going for 'F'ull case folding
+        if (/^([0-9A-F]+); ([CFI]); ((?:[0-9A-F]+)(?: [0-9A-F]+)*); \# (.+)/) {
+	    next if EBCDIC && hex $1 < 0x100;
+	    push @CF, [$1, $2, $3, $4];
+	}
+    }
+
+    close(CF);
+
+    die qq[$0: failed to find casefoldings from "$CF"\n] unless @CF;
+
+    print "1..", scalar @CF, "\n";
+
+    my $i = 0;
+    for my $cf (@CF) {
+	my ($code, $status, $mapping, $name) = @$cf;
+	$i++;
+	my $a = pack("U0U*", hex $code);
+	my $b = pack("U0U*", map { hex } split " ", $mapping);
+	my $t0 = ":$a:" =~ /:$a:/    ? 1 : 0;
+	my $t1 = ":$a:" =~ /:$a:/i   ? 1 : 0;
+	my $t2 = ":$a:" =~ /:[$a]:/  ? 1 : 0;
+	my $t3 = ":$a:" =~ /:[$a]:/i ? 1 : 0;
+	my $t4 = ":$a:" =~ /:$b:/i   ? 1 : 0;
+	my $t5 = ":$a:" =~ /:[$b]:/i ? 1 : 0;
+	my $t6 = ":$b:" =~ /:$a:/i   ? 1 : 0;
+	my $t7 = ":$b:" =~ /:[$a]:/i ? 1 : 0;
+	print $t0 && $t1 && $t2 && $t3 && $t4 && $t5 && $t6 && $t7 ?
+	    "ok $i \# - $code - $name - $mapping - $status\n" :
+	    "not ok $i \# - $code - $name - $mapping - $status - $t0 $t1 $t2 $t3 $t4 $t5 $t6 $t7\n";
+    }
+} else {
+    die qq[$0: failed to open "$CF": $!\n];
+}
diff --git a/gnu/usr.bin/perl/t/uni/lower.t b/gnu/usr.bin/perl/t/uni/lower.t
new file mode 100644
index 00000000000..4420d0b165d
--- /dev/null
+++ b/gnu/usr.bin/perl/t/uni/lower.t
@@ -0,0 +1,8 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(../lib uni .);
+    require "case.pl";
+}
+
+casetest("Lower", \%utf8::ToSpecLower, sub { lc $_[0] });
+
diff --git a/gnu/usr.bin/perl/t/uni/sprintf.t b/gnu/usr.bin/perl/t/uni/sprintf.t
new file mode 100644
index 00000000000..3c5f574b62c
--- /dev/null
+++ b/gnu/usr.bin/perl/t/uni/sprintf.t
@@ -0,0 +1,139 @@
+#!./perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(../lib .);
+    require "test.pl";
+}
+
+plan tests => 25;
+
+$a = "B\x{fc}f";
+$b = "G\x{100}r";
+$c = 0x200;
+
+{
+    my $s = sprintf "%s", $a;
+    is($s, $a, "%s a");
+}
+
+{
+    my $s = sprintf "%s", $b;
+    is($s, $b, "%s b");
+}
+
+{
+    my $s = sprintf "%s%s", $a, $b;
+    is($s, $a.$b, "%s%s a b");
+}
+
+{
+    my $s = sprintf "%s%s", $b, $a;
+    is($s, $b.$a, "%s%s b a");
+}
+
+{
+    my $s = sprintf "%s%s", $b, $b;
+    is($s, $b.$b, "%s%s b b");
+}
+
+{
+    my $s = sprintf "%s$b", $a;
+    is($s, $a.$b, "%sb a");
+}
+
+{
+    my $s = sprintf "$b%s", $a;
+    is($s, $b.$a, "b%s a");
+}
+
+{
+    my $s = sprintf "%s$a", $b;
+    is($s, $b.$a, "%sa b");
+}
+
+{
+    my $s = sprintf "$a%s", $b;
+    is($s, $a.$b, "a%s b");
+}
+
+{
+    my $s = sprintf "$a%s", $a;
+    is($s, $a.$a, "a%s a");
+}
+
+{
+    my $s = sprintf "$b%s", $b;
+    is($s, $b.$b, "a%s b");
+}
+
+{
+    my $s = sprintf "%c", $c;
+    is($s, chr($c), "%c c");
+}
+
+{
+    my $s = sprintf "%s%c", $a, $c;
+    is($s, $a.chr($c), "%s%c a c");
+}
+
+{
+    my $s = sprintf "%c%s", $c, $a;
+    is($s, chr($c).$a, "%c%s c a");
+}
+
+{
+    my $s = sprintf "%c$b", $c;
+    is($s, chr($c).$b, "%cb c");
+}
+
+{
+    my $s = sprintf "%s%c$b", $a, $c;
+    is($s, $a.chr($c).$b, "%s%cb a c");
+}
+
+{
+    my $s = sprintf "%c%s$b", $c, $a;
+    is($s, chr($c).$a.$b, "%c%sb c a");
+}
+
+{
+    my $s = sprintf "$b%c", $c;
+    is($s, $b.chr($c), "b%c c");
+}
+
+{
+    my $s = sprintf "$b%s%c", $a, $c;
+    is($s, $b.$a.chr($c), "b%s%c a c");
+}
+
+{
+    my $s = sprintf "$b%c%s", $c, $a;
+    is($s, $b.chr($c).$a, "b%c%s c a");
+}
+
+{
+    # 20010407.008 sprintf removes utf8-ness
+    $a = sprintf "\x{1234}";
+    is((sprintf "%x %d", unpack("U*", $a), length($a)),    "1234 1",
+       '\x{1234}');
+    $a = sprintf "%s", "\x{5678}";
+    is((sprintf "%x %d", unpack("U*", $a), length($a)),    "5678 1",
+       '%s \x{5678}');
+    $a = sprintf "\x{1234}%s", "\x{5678}";
+    is((sprintf "%x %x %d", unpack("U*", $a), length($a)), "1234 5678 2",
+       '\x{1234}%s \x{5678}');
+}
+
+{
+    # check that utf8ness doesn't "accumulate"
+
+    my $w = "w\x{fc}";
+    my $sprintf;
+
+    $sprintf = sprintf "%s%s", $w, "$w\x{100}";
+    is(substr($sprintf,0,2), $w, "utf8 echo");
+
+    $sprintf = sprintf "%s%s", $w, "$w\x{100}";    
+    is(substr($sprintf,0,2), $w, "utf8 echo echo");
+}
diff --git a/gnu/usr.bin/perl/t/uni/title.t b/gnu/usr.bin/perl/t/uni/title.t
new file mode 100644
index 00000000000..c0b7e3a0163
--- /dev/null
+++ b/gnu/usr.bin/perl/t/uni/title.t
@@ -0,0 +1,8 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(../lib uni .);
+    require "case.pl";
+}
+
+casetest("Title", \%utf8::ToSpecTitle, sub { ucfirst $_[0] });
+
diff --git a/gnu/usr.bin/perl/t/uni/upper.t b/gnu/usr.bin/perl/t/uni/upper.t
new file mode 100644
index 00000000000..5694c26f222
--- /dev/null
+++ b/gnu/usr.bin/perl/t/uni/upper.t
@@ -0,0 +1,8 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(../lib uni .);
+    require "case.pl";
+}
+
+casetest("Upper", \%utf8::ToSpecUpper, sub { uc $_[0] });
+
diff --git a/gnu/usr.bin/perl/t/win32/longpath.t b/gnu/usr.bin/perl/t/win32/longpath.t
new file mode 100644
index 00000000000..d31a5b4dce0
--- /dev/null
+++ b/gnu/usr.bin/perl/t/win32/longpath.t
@@ -0,0 +1,52 @@
+#!perl -w
+
+# tests for Win32::GetLongPathName()
+
+$^O =~ /^MSWin/ or print("1..0 # not win32\n" ), exit;
+
+my @paths = qw(
+    /
+    //
+    .
+    ..
+    c:
+    c:/
+    c:./
+    c:/.
+    c:/..
+    c:./..
+    //./
+    //.
+    //..
+    //./..
+);
+push @paths, map { my $x = $_; $x =~ s,/,\\,g; $x } @paths;
+push @paths, qw(
+    ../\
+    c:.\\../\
+    c:/\..//
+    c://.\/./\
+    \\.\\../\
+    //\..//
+    //.\/./\
+);
+
+my $drive = $ENV{SystemDrive};
+if ($drive) {
+    for (@paths) {
+	s/^c:/$drive/;
+    }
+    push @paths, $ENV{SystemRoot} if $ENV{SystemRoot};
+}
+my %expect;
+@expect{@paths} = map { my $x = $_; $x =~ s,(.[/\\])[/\\]+,$1,g; $x } @paths;
+
+print "1.." . @paths . "\n";
+my $i = 1;
+for (@paths) {
+    my $got = Win32::GetLongPathName($_);
+    print "# '$_' => expect '$expect{$_}' => got '$got'\n";
+    print "not " unless $expect{$_} eq $got;
+    print "ok $i\n";
+    ++$i;
+}
diff --git a/gnu/usr.bin/perl/t/win32/system.t b/gnu/usr.bin/perl/t/win32/system.t
new file mode 100644
index 00000000000..b1906ce73ab
--- /dev/null
+++ b/gnu/usr.bin/perl/t/win32/system.t
@@ -0,0 +1,174 @@
+#!perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    # XXX this could be further munged to enable some parts on other
+    # platforms
+    unless ($^O =~ /^MSWin/) {
+	print "1..0 # skipped: windows specific test\n";
+	exit 0;
+    }
+}
+
+use File::Path;
+use File::Copy;
+use Config;
+use Cwd;
+use strict;
+
+$| = 1;
+
+my $cwd = cwd();
+
+my $testdir = "t e s t";
+my $exename = "showav";
+my $plxname = "showargv";
+rmtree($testdir);
+mkdir($testdir);
+die "Could not create '$testdir':$!" unless -d $testdir;
+
+open(my $F, ">$testdir/$exename.c")
+    or die "Can't create $testdir/$exename.c: $!";
+print $F <<'EOT';
+#include <stdio.h>
+#ifdef __BORLANDC__
+#include <windows.h>
+#endif
+int
+main(int ac, char **av)
+{
+    int i;
+#ifdef __BORLANDC__
+    char *s = GetCommandLine();
+    int j=0;
+    av[0] = s;
+    if (s[0]=='"') {
+	for(;s[++j]!='"';)
+	  ;
+	av[0]++;
+    }
+    else {
+	for(;s[++j]!=' ';)
+	  ;
+    }
+    s[j]=0;
+#endif
+    for (i = 0; i < ac; i++)
+	printf("[%s]", av[i]);
+    printf("\n");
+    return 0;
+}
+EOT
+
+open($F, ">$testdir/$plxname.bat")
+    or die "Can't create $testdir/$plxname.bat: $!";
+print $F <<'EOT';
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+EOT
+
+print $F <<EOT;
+"$^X" -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+"$^X" -x -S %0 %*
+EOT
+print $F <<'EOT';
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+print "[$_]" for ($0, @ARGV);
+print "\n";
+__END__
+:endofperl
+EOT
+
+close $F;
+
+# build the executable
+chdir($testdir);
+END {
+    chdir($cwd) && rmtree("$cwd/$testdir") if -d "$cwd/$testdir";
+}
+if (open(my $EIN, "$cwd/win32/${exename}_exe.uu")) {
+    print "# Unpacking $exename.exe\n";
+    my $e;
+    {
+	local $/;
+	$e = unpack "u", <$EIN>;
+	close $EIN;
+    }
+    open my $EOUT, ">$exename.exe" or die "Can't write $exename.exe: $!";
+    binmode $EOUT;
+    print $EOUT $e;
+    close $EOUT;
+}
+else {
+    my $minus_o = '';
+    if ($Config{cc} eq 'gcc')
+     {
+      $minus_o = "-o $exename.exe";
+     }
+    print "# Compiling $exename.c\n# $Config{cc} $Config{ccflags} $exename.c\n";
+    if (system("$Config{cc} $Config{ccflags} $minus_o $exename.c >log 2>&1") != 0) {
+	print "# Could not compile $exename.c, status $?\n"
+	     ."# Where is your C compiler?\n"
+	     ."1..0 # skipped: can't build test executable\n";
+	exit(0);
+    }
+    unless (-f "$exename.exe") {
+	if (open(LOG,'<log'))
+         {
+          while(<LOG>) {
+	     print "# ",$_;
+          } 
+         }
+        else {
+	  warn "Cannot open log (in $testdir):$!";
+        }
+    }
+}
+copy("$plxname.bat","$plxname.cmd");
+chdir($cwd);
+unless (-x "$testdir/$exename.exe") {
+    print "# Could not build $exename.exe\n"
+	 ."1..0 # skipped: can't build test executable\n";
+    exit(0);
+}
+
+open my $T, "$^X -I../lib -w win32/system_tests |"
+    or die "Can't spawn win32/system_tests: $!";
+my $expect;
+my $comment = "";
+my $test = 0;
+while (<$T>) {
+    chomp;
+    if (/^1\.\./) {
+	print "$_\n";
+    }
+    elsif (/^#+\s(.*)$/) {
+	$comment = $1;
+    }
+    elsif (/^</) {
+	$expect = $_;
+	$expect =~ tr/<>/[]/;
+	$expect =~ s/\Q$plxname\E]/$plxname.bat]/;
+    }
+    else {
+	if ($expect ne $_) {
+	    print "# $comment\n" if $comment;
+	    print "# want: $expect\n";
+	    print "# got : $_\n";
+	    print "not ";
+	}
+	++$test;
+	print "ok $test\n";
+    }
+}
+close $T;
diff --git a/gnu/usr.bin/perl/t/win32/system_tests b/gnu/usr.bin/perl/t/win32/system_tests
new file mode 100644
index 00000000000..f73745ae8fc
--- /dev/null
+++ b/gnu/usr.bin/perl/t/win32/system_tests
@@ -0,0 +1,120 @@
+#!perl
+
+use Config;
+use Cwd;
+use strict;
+
+$| = 1;
+
+my $cwdb = my $cwd = cwd();
+$cwd =~ s,\\,/,g;
+$cwdb =~ s,/,\\,g;
+
+my $testdir = "t e s t";
+my $exename = "showav";
+my $plxname = "showargv";
+
+my $exe = "$testdir/$exename";
+my $exex = $exe . ".exe";
+(my $exeb = $exe) =~ s,/,\\,g;
+my $exebx = $exeb . ".exe";
+
+my $bat = "$testdir/$plxname";
+my $batx = $bat . ".bat";
+(my $batb = $bat) =~ s,/,\\,g;
+my $batbx = $batb . ".bat";
+
+my $cmdx = $bat . ".cmd";
+my $cmdb = $batb;
+my $cmdbx = $cmdb . ".cmd";
+
+my @commands = (
+  $exe,
+  $exex,
+  $exeb,
+  $exebx,
+  "./$exe",
+  "./$exex",
+  ".\\$exeb",
+  ".\\$exebx",
+  "$cwd/$exe",
+  "$cwd/$exex",
+  "$cwdb\\$exeb",
+  "$cwdb\\$exebx",
+  $bat,
+  $batx,
+  $batb,
+  $batbx,
+  "./$bat",
+  "./$batx",
+  ".\\$batb",
+  ".\\$batbx",
+  "$cwd/$bat",
+  "$cwd/$batx",
+  "$cwdb\\$batb",
+  "$cwdb\\$batbx",
+  $cmdx,
+  $cmdbx,
+  "./$cmdx",
+  ".\\$cmdbx",
+  "$cwd/$cmdx",
+  "$cwdb\\$cmdbx",
+  [$^X, $batx],
+  [$^X, $batbx],
+  [$^X, "./$batx"],
+  [$^X, ".\\$batbx"],
+  [$^X, "$cwd/$batx"],
+  [$^X, "$cwdb\\$batbx"],
+);
+
+my @av = (
+  undef,
+  "",
+  " ",
+  "abc",
+  "a b\tc",
+  "\tabc",
+  "abc\t",
+  " abc\t",
+  "\ta b c ",
+  ["\ta b c ", ""],
+  ["\ta b c ", " "],
+  ["", "\ta b c ", "abc"],
+  [" ", "\ta b c ", "abc"],
+  ['" "', 'a" "b" "c', "abc"],
+);
+
+print "1.." . (@commands * @av * 2) . "\n";
+for my $cmds (@commands) {
+    for my $args (@av) {
+	my @all_args;
+	my @cmds = defined($cmds) ? (ref($cmds) ? @$cmds : $cmds) : ();
+	my @args = defined($args) ? (ref($args) ? @$args : $args) : ();
+	print "######## [@cmds]\n";
+	print "<", join('><',
+			$cmds[$#cmds],
+			map { my $x = $_; $x =~ s/"//g; $x } @args),
+	      ">\n";
+	if (system(@cmds,@args) != 0) {
+	    print "Failed, status($?)\n";
+	    if ($Config{ccflags} =~ /\bDDEBUGGING\b/) {
+		print "Running again in debug mode\n";
+		$^D = 1; # -Dp
+		system(@cmds,@args);
+	    }
+	}
+	$^D = 0;
+	my $cmdstr = join " ", map { /\s|^$/ && !/\"/
+				    ? qq["$_"] : $_ } @cmds, @args;
+	print "######## '$cmdstr'\n";
+	if (system($cmdstr) != 0) {
+	    print "Failed, status($?)\n";
+	    if ($Config{ccflags} =~ /\bDDEBUGGING\b/) {
+		print "Running again in debug mode\n";
+		$^D = 1; # -Dp
+		system($cmdstr);
+	    }
+	}
+	$^D = 0;
+    }
+}
diff --git a/gnu/usr.bin/perl/t/x2p/s2p.t b/gnu/usr.bin/perl/t/x2p/s2p.t
new file mode 100644
index 00000000000..39c6cd80557
--- /dev/null
+++ b/gnu/usr.bin/perl/t/x2p/s2p.t
@@ -0,0 +1,873 @@
+#!./perl
+
+=head1 NAME
+
+s2p.t - test suite for s2p/psed
+
+=head1 NOTES
+
+The general idea is to
+
+  (a) run psed with a sed script and input data to obtain some output
+  (b) run s2p with a sed script creating a Perl program and then run the
+      Perl program with the input data, again producing output
+
+Both final outputs should be identical to the expected output.
+
+A $testcase{<name>} contains entries (after the comment ### <name> ###):
+
+  - script: the sed script
+  - input:  the key of the input data, stored in $input{<input>}
+  - expect: the expected output
+  - datfil: an additional file [ <path>, <data> ] (if required)
+
+Temporary files are created in the working directory (embedding $$
+in the name), and removed after the test.
+
+Except for bin2dec (which indeed converts binary to decimal) none of the
+sed scripts is doing something useful.
+
+Author: Wolfgang Laun.
+
+=cut
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = ( '../lib' );
+}
+
+### use Test::More;
+use File::Copy;
+use File::Spec;
+require './test.pl';
+
+# BRE extensions
+$ENV{PSEDEXTBRE} = '<>wW';
+
+our %input = (
+   bins => <<'[TheEnd]',
+0
+111
+1000
+10001
+[TheEnd]
+
+   text => <<'[TheEnd]',
+line 1
+line 2
+line 3
+line 4
+line 5
+line 6
+line 7
+line 8
+[TheEnd]
+
+   adr1 => <<'[TheEnd]',
+#no autoprint
+# This script should be run on itself
+/^#__DATA__$/,${
+   /^#A$/p
+   s/^# *[0-9]* *//
+   /^#\*$/p
+   /^#\.$/p
+   /^#\(..\)\(..\)\2\1*$/p
+   /^#[abc]\{1,\}[def]\{1,\}$/p
+}
+#__DATA__
+#A
+#*
+#.
+#abxyxy
+#abxyxyab
+#abxyxyabab
+#ad
+#abcdef
+[TheEnd]
+);
+
+
+our %testcase = (
+
+### bin2dec ###
+'bin2dec' => {
+  script => <<'[TheEnd]',
+# binary -> decimal
+s/^[ 	]*\([01]\{1,\}\)[ 	]*/\1/
+t go
+i\
+is not a binary number
+d
+
+# expand binary to Xs
+: go
+s/^0*//
+s/^1/X/
+: expand
+s/^\(X\{1,\}\)0/\1\1/
+s/^\(X\{1,\}\)1/\1\1X/
+t expand
+
+# count Xs in decimal
+: count
+s/^X/1/
+s/0X/1/
+s/1X/2/
+s/2X/3/
+s/3X/4/
+s/4X/5/
+s/5X/6/
+s/6X/7/
+s/7X/8/
+s/8X/9/
+s/9X/X0/
+t count
+s/^$/0/
+[TheEnd]
+  input  => 'bins',
+  expect => <<'[TheEnd]',
+0
+7
+8
+17
+[TheEnd]
+},
+
+
+### = ###
+'=' => {
+  script => <<'[TheEnd]',
+1=
+$=
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+1
+line 1
+line 2
+line 3
+line 4
+line 5
+line 6
+line 7
+8
+line 8
+[TheEnd]
+},
+
+### D ###
+'D' => {
+  script => <<'[TheEnd]',
+#no autoprint
+/1/{
+N
+N
+N
+D
+}
+p
+/2/D
+=
+p
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+line 2
+line 3
+line 4
+line 3
+line 4
+4
+line 3
+line 4
+line 5
+5
+line 5
+line 6
+6
+line 6
+line 7
+7
+line 7
+line 8
+8
+line 8
+[TheEnd]
+},
+
+### H ###
+'H' => {
+  script => <<'[TheEnd]',
+#no autoprint
+1,$H
+$g
+$=
+$p
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+8
+
+line 1
+line 2
+line 3
+line 4
+line 5
+line 6
+line 7
+line 8
+[TheEnd]
+},
+
+### N ###
+'N' => {
+  script => <<'[TheEnd]',
+3a\
+added line
+4a\
+added line
+5a\
+added line
+3,5N
+=
+d
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+1
+2
+added line
+4
+added line
+6
+7
+8
+[TheEnd]
+},
+
+### P ###
+'P' => {
+  script => <<'[TheEnd]',
+1N
+2N
+3N
+4=
+4P
+4,$d
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+4
+line 1
+[TheEnd]
+},
+
+### a ###
+'a' => {
+  script => <<'[TheEnd]',
+1a\
+added line 1.1\
+added line 1.2
+
+3a\
+added line 3.1
+3a\
+added line 3.2
+
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+line 1
+added line 1.1
+added line 1.2
+line 2
+line 3
+added line 3.1
+added line 3.2
+line 4
+line 5
+line 6
+line 7
+line 8
+[TheEnd]
+},
+
+### b ###
+'b' => {
+  script => <<'[TheEnd]',
+#no autoprint
+2 b eos
+4 b eos
+p
+: eos
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+line 1
+line 3
+line 5
+line 6
+line 7
+line 8
+[TheEnd]
+},
+
+### block ###
+'block' => {
+  script => "#no autoprint\n1,3{\n=\np\n}",
+  input  => 'text',
+  expect => <<'[TheEnd]',
+1
+line 1
+2
+line 2
+3
+line 3
+[TheEnd]
+},
+
+### c ###
+'c' => {
+  script => <<'[TheEnd]',
+2=
+
+2,4c\
+change 2,4 line 1\
+change 2,4 line 2
+
+2=
+
+3,5c\
+change 3,5 line 1\
+change 3,5 line 2
+
+3=
+
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+line 1
+2
+change 2,4 line 1
+change 2,4 line 2
+line 5
+line 6
+line 7
+line 8
+[TheEnd]
+},
+
+### c1 ###
+'c1' => {
+  script => <<'[TheEnd]',
+1c\
+replaces line 1
+
+2,3c\
+replaces lines 2-3
+
+/5/,/6/c\
+replaces lines 3-4
+
+8,10c\
+replaces lines 6-10
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+replaces line 1
+replaces lines 2-3
+line 4
+replaces lines 3-4
+line 7
+[TheEnd]
+},
+
+### c2 ###
+'c2' => {
+  script => <<'[TheEnd]',
+3!c\
+replace all except line 3
+
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+replace all except line 3
+replace all except line 3
+line 3
+replace all except line 3
+replace all except line 3
+replace all except line 3
+replace all except line 3
+replace all except line 3
+[TheEnd]
+},
+
+### c3 ###
+'c3' => {
+  script => <<'[TheEnd]',
+1,4!c\
+replace all except 1-4
+
+/5/,/8/!c\
+replace all except 5-8
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+replace all except 5-8
+replace all except 5-8
+replace all except 5-8
+replace all except 5-8
+replace all except 1-4
+replace all except 1-4
+replace all except 1-4
+replace all except 1-4
+[TheEnd]
+},
+
+### d ###
+'d' => {
+  script => <<'[TheEnd]',
+# d delete pattern space, start next cycle
+2,4 d
+5 d
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+line 1
+line 6
+line 7
+line 8
+[TheEnd]
+},
+
+### gh ###
+'gh' => {
+  script => <<'[TheEnd]',
+1h
+2g
+3h
+4g
+5q
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+line 1
+line 1
+line 3
+line 3
+line 5
+[TheEnd]
+},
+
+### i ###
+'i' => {
+  script => <<'[TheEnd]',
+1i\
+inserted line 1.1\
+inserted line 1.2
+
+3i\
+inserted line 3.1
+3i\
+inserted line 3.2
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+inserted line 1.1
+inserted line 1.2
+line 1
+line 2
+inserted line 3.1
+inserted line 3.2
+line 3
+line 4
+line 5
+line 6
+line 7
+line 8
+[TheEnd]
+},
+
+### n ###
+'n' => {
+  script => <<'[TheEnd]',
+3a\
+added line
+4a\
+added line
+5a\
+added line
+3,5n
+=
+d
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+1
+2
+line 3
+added line
+4
+line 5
+added line
+6
+7
+8
+[TheEnd]
+},
+
+### o ###
+'o' => {
+  script => <<'[TheEnd]',
+/abc/,/def/ s//XXX/
+// i\
+cheers
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+line 1
+line 2
+line 3
+line 4
+line 5
+line 6
+line 7
+line 8
+[TheEnd]
+},
+
+### q ###
+'q' => {
+  script => <<'[TheEnd]',
+2a\
+append to line 2
+3a\
+append to line 3 - should not appear in output
+3q
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+line 1
+line 2
+append to line 2
+line 3
+[TheEnd]
+},
+
+### r ###
+'r' => {
+  datfil => [ 'r.txt', "r.txt line 1\nr.txt line 2\nr.txt line 3\n" ],
+  script => <<'[TheEnd]',
+2r%r.txt%
+4r %r.txt%
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+line 1
+line 2
+r.txt line 1
+r.txt line 2
+r.txt line 3
+line 3
+line 4
+r.txt line 1
+r.txt line 2
+r.txt line 3
+line 5
+line 6
+line 7
+line 8
+[TheEnd]
+},
+
+### s ###
+'s' => {
+  script => <<'[TheEnd]',
+# enclose any `(a)'.. `(c)' in `-'
+s/([a-z])/-\1-/g
+
+s/\([abc]\)/-\1-/g
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+line 1
+line 2
+line 3
+line 4
+line 5
+line 6
+line 7
+line 8
+[TheEnd]
+},
+
+### s1 ###
+'s1' => {
+  script => <<'[TheEnd]',
+s/\w/@1/
+s/\y/@2/
+
+s/\n/@3/
+
+# this is literal { }
+s/a{3}/@4/
+
+# proper repetition
+s/a\{3\}/a rep 3/
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+@1ine 1
+@1ine 2
+@1ine 3
+@1ine 4
+@1ine 5
+@1ine 6
+@1ine 7
+@1ine 8
+[TheEnd]
+},
+
+### t ###
+'t' => {
+  script => join( "\n",
+   '#no autoprint', 's/./X/p', 's/foo/bar/p', 't bye', '=', 'p', ':bye' ),
+  input  => 'text',
+  expect => <<'[TheEnd]',
+Xine 1
+Xine 2
+Xine 3
+Xine 4
+Xine 5
+Xine 6
+Xine 7
+Xine 8
+[TheEnd]
+},
+
+### w ###
+'w' => {
+  datfil => [ 'w.txt', '' ],
+  script => <<'[TheEnd]',
+w %w.txt%
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+line 1
+line 2
+line 3
+line 4
+line 5
+line 6
+line 7
+line 8
+[TheEnd]
+},
+
+### x ###
+'x' => {
+  script => <<'[TheEnd]',
+1h
+1d
+2x
+2,$G
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+line 1
+line 2
+line 3
+line 2
+line 4
+line 2
+line 5
+line 2
+line 6
+line 2
+line 7
+line 2
+line 8
+line 2
+[TheEnd]
+},
+
+### y ###
+'y' => {
+  script => <<'[TheEnd]',
+y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/
+y/|/\
+/ 
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+LINE 1
+LINE 2
+LINE 3
+LINE 4
+LINE 5
+LINE 6
+LINE 7
+LINE 8
+[TheEnd]
+},
+
+### cnt ###
+'cnt' => {
+  script => <<'[TheEnd]',
+#no autoprint
+
+# delete line, append NL to hold space
+s/.*//
+H
+$!b
+
+# last line only: get hold
+g
+s/./X/g
+t count
+: count
+s/^X/1/
+s/0X/1/
+s/1X/2/
+s/2X/3/
+s/3X/4/
+s/4X/5/
+s/5X/6/
+s/6X/7/
+s/7X/8/
+s/8X/9/
+s/9X/X0/
+t count
+p
+[TheEnd]
+  input  => 'text',
+  expect => <<'[TheEnd]',
+8
+[TheEnd]
+},
+
+### adr1 ###
+'adr1' => {
+  script => <<'[TheEnd]',
+#no autoprint
+# This script should be run on itself
+/^#__DATA__$/,${
+   /^#A$/p
+   s/^# *[0-9]* *//
+   /^#\*$/p
+   /^#\.$/p
+   /^#\(..\)\(..\)\2\1*$/p
+   /^#[abc]\{1,\}[def]\{1,\}$/p
+}
+#__DATA__
+#A
+#*
+#.
+#abxyxy
+#abxyxyab
+#abxyxyabab
+#ad
+#abcdef
+[TheEnd]
+  input  => 'adr1',
+  expect => <<'[TheEnd]',
+#A
+[TheEnd]
+},
+
+);
+
+my @aux = ();
+my $ntc = 2 * keys %testcase;
+plan( $ntc );
+
+# temporary file names
+my $script = "s2pt$$.sed";
+my $stdin  = "s2pt$$.in";
+my $plsed  = "s2pt$$.pl";
+
+# various command lines for 
+my $s2p  = File::Spec->catfile( File::Spec->updir(), 'x2p', 's2p' );
+my $psed = File::Spec->catfile( File::Spec->curdir(), 'psed' );
+if ($^O eq 'VMS') {
+  # default in the .com extenson if it's not already there
+  $s2p = VMS::Filespec::rmsexpand($s2p, '.com');
+  $psed = VMS::Filespec::rmsexpand($psed, '.com');
+}
+my $sedcmd = [ $psed, '-f', $script, $stdin ];
+my $s2pcmd = [ $s2p,  '-f', $script ];
+my $plcmd  = [ $plsed, $stdin ];
+
+my $switches = '';
+$switches = ['-x'] if $^O eq 'MacOS';
+
+# psed: we create a local copy as linking may not work on some systems.
+copy( $s2p, $psed );
+push( @aux, $psed );
+
+# process all testcases
+#
+my $indat = '';
+for my $tc ( sort keys %testcase ){
+    my( $psedres, $s2pres );
+
+    # 1st test: run psed
+    # prepare the script 
+    open( SED, ">$script" ) || goto FAIL_BOTH;
+    my $script = $testcase{$tc}{script};
+
+    # additional files for r, w: patch script, inserting temporary names
+    if( exists( $testcase{$tc}{datfil} ) ){
+        my( $datnam, $datdat ) = @{$testcase{$tc}{datfil}};
+        my $datfil = "s2pt$$" . $datnam;
+        push( @aux, $datfil );
+        open( DAT, ">$datfil" ) || goto FAIL_BOTH;
+        print DAT $datdat;
+        close( DAT );
+        $script =~ s/\%$datnam\%/$datfil/eg;
+    }
+    print SED $script;
+    close( SED ) || goto FAIL_BOTH;
+
+    # prepare input
+    #
+    if( $indat ne $testcase{$tc}{input} ){
+        $indat = $testcase{$tc}{input};
+        open( IN, ">$stdin" ) || goto FAIL_BOTH;
+        print IN $input{$indat};
+        close( IN ) || goto FAIL_BOTH;
+    }
+
+    # on VMS, runperl eats blank lines to work around 
+    # spurious newlines in pipes
+    $testcase{$tc}{expect} =~ s/\n\n/\n/ if $^O eq 'VMS';
+
+    # run and compare
+    #
+    $psedres = runperl( args => $sedcmd, switches => $switches );
+    is( $psedres, $testcase{$tc}{expect}, "psed $tc" );
+
+    # 2nd test: run s2p
+    # translate the sed script to a Perl program
+
+    my $perlprog = runperl( args => $s2pcmd, switches => $switches );
+    open( PP, ">$plsed" ) || goto FAIL_S2P;
+    print PP $perlprog;
+    close( PP ) || goto FAIL_S2P;
+
+    # execute generated Perl program, compare
+    $s2pres = runperl( args => $plcmd, switches => $switches );
+    is( $s2pres, $testcase{$tc}{expect}, "s2p $tc" );
+    next;
+
+FAIL_BOTH:
+    fail( "psed $tc" );
+FAIL_S2P:
+    fail( "s2p $tc" );
+}
+
+END {
+    for my $f ( $script, $stdin, $plsed, @aux ){
+        1 while unlink( $f ); # hats off to VMS...
+    }
+}