Once again syncing after too long an absence

p4raw-id: //depot/vmsperl@8367

9 files changed, 476 insertions, 290 deletions

diff --git a/t/pragma/constant.t b/t/pragma/constant.t
index 450b4d02cf..f932976f60 100755
--- a/t/pragma/constant.t
+++ b/t/pragma/constant.t
@@ -14,7 +14,7 @@ END { print @warnings }
 
 ######################### We start with some black magic to print on failure.
 
-BEGIN { $| = 1; print "1..73\n"; }
+BEGIN { $| = 1; print "1..82\n"; }
 END {print "not ok 1\n" unless $loaded;}
 use constant 1.01;
 $loaded = 1;
@@ -229,3 +229,23 @@ test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main:
 test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/;
 test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/;
 @warnings = ();
+
+
+use constant {
+	THREE  => 3,
+	FAMILY => [ qw( John Jane Sally ) ],
+	AGES   => { John => 33, Jane => 28, Sally => 3 },
+	RFAM   => [ [ qw( John Jane Sally ) ] ],
+	SPIT   => sub { shift },
+	PHFAM  => [ { John => 1, Jane => 2, Sally => 3 }, 33, 28, 3 ],
+};
+
+test 74, @{+FAMILY} == THREE;
+test 75, @{+FAMILY} == @{RFAM->[0]};
+test 76, FAMILY->[2] eq RFAM->[0]->[2];
+test 77, AGES->{FAMILY->[1]} == 28;
+test 78, PHFAM->{John} == AGES->{John};
+test 79, PHFAM->[3] == AGES->{FAMILY->[2]};
+test 80, @{+PHFAM} == SPIT->(THREE+1);
+test 81, THREE**3 eq SPIT->(@{+FAMILY}**3);
+test 82, AGES->{FAMILY->[THREE-1]} == PHFAM->[THREE];
diff --git a/t/pragma/locale.t b/t/pragma/locale.t
index c8a0df8724..61528b35c3 100755
--- a/t/pragma/locale.t
+++ b/t/pragma/locale.t
@@ -34,7 +34,9 @@ eval {
 # and mingw32 uses said silly CRT
 $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i;
 
-print "1..", ($have_setlocale ? 116 : 98), "\n";
+my $last = $have_setlocale ? 116 : 98;
+
+print "1..$last\n";
 
 use vars qw(&LC_ALL);
 
@@ -242,13 +244,13 @@ Afrikaans:af:za:1 15
 Arabic:ar:dz eg sa:6 arabic8
 Brezhoneg Breton:br:fr:1 15
 Bulgarski Bulgarian:bg:bg:5
-Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW GB2312 tw.EUC
+Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC
 Hrvatski Croatian:hr:hr:2
 Cymraeg Welsh:cy:cy:1 14 15
 Czech:cs:cz:2
 Dansk Danish:dk:da:1 15
 Nederlands Dutch:nl:be nl:1 15
-English American British:en:au ca gb ie nz us uk:1 15 cp850
+English American British:en:au ca gb ie nz us uk zw:1 15 cp850
 Esperanto:eo:eo:3
 Eesti Estonian:et:ee:4 6 13
 Suomi Finnish:fi:fi:1 15
@@ -271,11 +273,12 @@ Latvian:lv:lv:4 6 13
 Lithuanian:lt:lt:4 6 13
 Macedonian:mk:mk:1 15
 Maltese:mt:mt:3
-Norsk Norwegian:no:no:1 15
+Moldovan:mo:mo:2
+Norsk Norwegian:no no\@nynorsk:no:1 15
 Occitan:oc:es:1 15
 Polski Polish:pl:pl:2
 Rumanian:ro:ro:2
-Russki Russian:ru:ru su ua:5 koi8 koi8r koi8u cp1251
+Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866
 Serbski Serbian:sr:yu:5
 Slovak:sk:sk:2
 Slovene Slovenian:sl:si:2
@@ -283,10 +286,11 @@ Sqhip Albanian:sq:sq:1 15
 Svenska Swedish:sv:fi se:1 15
 Thai:th:th:11 tis620
 Turkish:tr:tr:9 turkish8
-Yiddish:::1 15
+Yiddish:yi::1 15
 EOF
 
 if ($^O eq 'os390') {
+    # These cause heartburn.  Broken locales?
     $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//;
     $locales =~ s/Thai:th:th:11 tis620\n//;
 }
@@ -326,6 +330,7 @@ sub decode_encodings {
 	    }
 	} else {
 	    push @enc, $_;
+   	    push @enc, "$_.UTF-8";
 	}
     }
     if ($^O eq 'os390') {
@@ -347,32 +352,61 @@ foreach (0..15) {
     trylocale("iso_latin_$_");
 }
 
-foreach my $locale (split(/\n/, $locales)) {
-    my ($locale_name, $language_codes, $country_codes, $encodings) =
-	split(/:/, $locale);
-    my @enc = decode_encodings($encodings);
-    foreach my $loc (split(/ /, $locale_name)) {
-	trylocale($loc);
-	foreach my $enc (@enc) {
-	    trylocale("$loc.$enc");
-	}
-	$loc = lc $loc;
-	foreach my $enc (@enc) {
-	    trylocale("$loc.$enc");
-	}
+# Sanitize the environment so that we can run the external 'locale'
+# program without the taint mode getting grumpy.
+
+# $ENV{PATH} is special in VMS.
+delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv};
+
+# Other subversive stuff.
+delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
+
+if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) {
+    while (<LOCALES>) {
+        chomp;
+	trylocale($_);
     }
-    foreach my $lang (split(/ /, $language_codes)) {
-	trylocale($lang);
-	foreach my $country (split(/ /, $country_codes)) {
-	    my $lc = "${lang}_${country}";
-	    trylocale($lc);
+    close(LOCALES);
+} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') {
+# The SYS$I18N_LOCALE logical name search list was not present on 
+# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions.
+    opendir(LOCALES, "SYS\$I18N_LOCALE:");
+    while ($_ = readdir(LOCALES)) {
+        chomp;
+        trylocale($_);
+    }
+    close(LOCALES);
+} else {
+
+    # This is going to be slow.
+
+    foreach my $locale (split(/\n/, $locales)) {
+	my ($locale_name, $language_codes, $country_codes, $encodings) =
+	    split(/:/, $locale);
+	my @enc = decode_encodings($encodings);
+	foreach my $loc (split(/ /, $locale_name)) {
+	    trylocale($loc);
 	    foreach my $enc (@enc) {
-		trylocale("$lc.$enc");
+		trylocale("$loc.$enc");
 	    }
-	    my $lC = "${lang}_\U${country}";
-	    trylocale($lC);
+	    $loc = lc $loc;
 	    foreach my $enc (@enc) {
-		trylocale("$lC.$enc");
+		trylocale("$loc.$enc");
+	    }
+	}
+	foreach my $lang (split(/ /, $language_codes)) {
+	    trylocale($lang);
+	    foreach my $country (split(/ /, $country_codes)) {
+		my $lc = "${lang}_${country}";
+		trylocale($lc);
+		foreach my $enc (@enc) {
+		    trylocale("$lc.$enc");
+		}
+		my $lC = "${lang}_\U${country}";
+		trylocale($lC);
+		foreach my $enc (@enc) {
+		    trylocale("$lC.$enc");
+		}
 	    }
 	}
     }
@@ -380,6 +414,8 @@ foreach my $locale (split(/\n/, $locales)) {
 
 setlocale(LC_ALL, "C");
 
+sub utf8locale { $_[0] =~ /utf-?8/i }
+
 @Locale = sort @Locale;
 
 debug "# Locales = @Locale\n";
@@ -470,7 +506,10 @@ foreach $Locale (@Locale) {
 
 	# Test \w.
     
-	{
+	if (utf8locale($Locale)) {
+	    # Until the polymorphic regexen arrive.
+	    debug "# skipping UTF-8 locale '$Locale'\n";
+	} else {
 	    my $word = join('', @Neoalpha);
 
 	    $word =~ /^(\w+)$/;
@@ -623,6 +662,9 @@ foreach $Locale (@Locale) {
     }
 
     debug "# testing 115 with locale '$Locale'\n";
+    # Does taking lc separately differ from taking
+    # the lc "in-line"?  (This was the bug 19990704.002, change #3568.)
+    # The bug was in the caching of the 'o'-magic.
     {
 	use locale;
 
@@ -646,7 +688,13 @@ foreach $Locale (@Locale) {
     }
 
     debug "# testing 116 with locale '$Locale'\n";
-    {
+    # Does lc of an UPPER (if different from the UPPER) match
+    # case-insensitively the UPPER, and does the UPPER match
+    # case-insensitively the lc of the UPPER.  And vice versa.
+    if (utf8locale($Locale)) {
+        # Until the polymorphic regexen arrive.
+        debug "# skipping UTF-8 locale '$Locale'\n";
+    } else {
 	use locale;
 
 	my @f = ();
@@ -661,15 +709,16 @@ foreach $Locale (@Locale) {
 	    push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
 	}
 	tryneoalpha($Locale, 116, @f == 0);
-	print "# testing 116 failed for locale '$Locale' for characters @f\n"
-            if @f;
+        if (@f) {
+	    print "# failed 116 locale '$Locale' characters @f\n"
+        }
     }
 
 }
 
 # Recount the errors.
 
-foreach (99..116) {
+foreach (99..$last) {
     if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
 	if ($_ == 102) {
 	    print "# The failure of test 102 is not necessarily fatal.\n";
@@ -685,7 +734,7 @@ foreach (99..116) {
 
 my $didwarn = 0;
 
-foreach (99..116) {
+foreach (99..$last) {
     if ($Problem{$_}) {
 	my @f = sort keys %{ $Problem{$_} };
 	my $f = join(" ", @f);
@@ -710,17 +759,18 @@ EOW
     }
 }
 
-# Tell which locales were okay.
+# Tell which locales were okay and which were not.
 
 if ($didwarn) {
-    my @s;
+    my (@s, @F);
     
     foreach my $l (@Locale) {
 	my $p = 0;
-	foreach my $t (102..116) {
+	foreach my $t (102..$last) {
 	    $p++ if $Problem{$t}{$l};
 	}
 	push @s, $l if $p == 0;
+      push @F, $l unless $p == 0;
     }
     
     if (@s) {
@@ -732,7 +782,19 @@ if ($didwarn) {
             "#\t", $s, "\n#\n",
 	    "# tested okay.\n#\n",
     } else {
-        warn "# None of your locales was fully okay.\n";
+        warn "# None of your locales were fully okay.\n";
+    }
+
+    if (@F) {
+        my $F = join(" ", @F);
+        $F =~ s/(.{50,60}) /$1\n#\t/g;
+
+        warn
+          "# The following locales\n#\n",
+            "#\t", $F, "\n#\n",
+          "# had problems.\n#\n",
+    } else {
+        warn "# None of your locales were broken.\n";
     }
 }
 
diff --git a/t/pragma/overload.t b/t/pragma/overload.t
index c7105dc9ca..bf24c07ec9 100755
--- a/t/pragma/overload.t
+++ b/t/pragma/overload.t
@@ -133,6 +133,7 @@ test ( $a eq "087");		# 29
 test ( $b eq "88");		# 30
 test (ref $a eq "Oscalar");	# 31
 
+undef $b;			# Destroying updates tables too...
 
 eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
 
diff --git a/t/pragma/sub_lval.t b/t/pragma/sub_lval.t
index 3ab8766892..a54075dd64 100755
--- a/t/pragma/sub_lval.t
+++ b/t/pragma/sub_lval.t
@@ -1,4 +1,4 @@
-print "1..46\n";
+print "1..49\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -334,8 +334,8 @@ print "# '$_'.\nnot "
   unless /Can\'t return a temporary from lvalue subroutine/;
 print "ok 38\n";
 
-sub xxx () { 'xxx' } # Not lvalue
-sub lv1tmpr : lvalue { xxx }			# is it a TEMP?
+sub yyy () { 'yyy' } # Const, not lvalue
+sub lv1tmpr : lvalue { yyy }			# is it read-only?
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
@@ -427,3 +427,25 @@ $a = \&lv1nn;
 $a->() = 8;
 print "# '$nnewvar'.\nnot " unless $nnewvar eq '8';
 print "ok 46\n";
+
+# This must happen at run time
+eval {
+    sub AUTOLOAD : lvalue { $newvar };
+};
+foobar() = 12;
+print "# '$newvar'.\nnot " unless $newvar eq "12";
+print "ok 47\n";
+
+# Testing DWIM of foo = bar;
+sub foo : lvalue {
+    $a;
+}
+$a = "not ok 48\n";
+foo = "ok 48\n";
+print $a;
+
+open bar, ">nothing" or die $!; 
+bar = *STDOUT;
+print bar "ok 49\n";
+unlink "nothing";
+
diff --git a/t/pragma/utf8.t b/t/pragma/utf8.t
index c3538c0cb5..8e4d296f5d 100755
--- a/t/pragma/utf8.t
+++ b/t/pragma/utf8.t
@@ -10,7 +10,7 @@ BEGIN {
     }
 }
 
-print "1..99\n";
+print "1..105\n";
 
 my $test = 1;
 
@@ -42,6 +42,7 @@ sub nok_bytes {
 
 {
     use utf8;
+
     $_ = ">\x{263A}<"; 
     s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg; 
     ok $_, '>&#9786;<';
@@ -104,215 +105,193 @@ sub nok_bytes {
     ok $1, '123alpha';
     $test++;				# 12
 }
-{
-    use utf8;
-
-    $_ = "\x{263A}>\x{263A}\x{263A}"; 
 
-    ok length, 4;
-    $test++;				# 13
-
-    ok length((m/>(.)/)[0]), 1;
-    $test++;				# 14
-
-    ok length($&), 2;
-    $test++;				# 15
+{
+    # no use utf8 needed
+    $_ = "\x{263A}\x{263A}x\x{263A}y\x{263A}";
+    
+    ok length($_), 6;			# 13
+    $test++;
 
-    ok length($'), 1;
-    $test++;				# 16
+    ($a) = m/x(.)/;
 
-    ok length($`), 1;
-    $test++;				# 17
+    ok length($a), 1;			# 14
+    $test++;
 
-    ok length($1), 1;
-    $test++;				# 18
+    ok length($`), 2;			# 15
+    $test++;
+    ok length($&), 2;			# 16
+    $test++;
+    ok length($'), 2;			# 17
+    $test++;
 
-    ok length($tmp=$&), 2;
-    $test++;				# 19
+    ok length($1), 1;			# 18
+    $test++;
 
-    ok length($tmp=$'), 1;
-    $test++;				# 20
+    ok length($b=$`), 2;		# 19
+    $test++;
 
-    ok length($tmp=$`), 1;
-    $test++;				# 21
+    ok length($b=$&), 2;		# 20
+    $test++;
 
-    ok length($tmp=$1), 1;
-    $test++;				# 22
+    ok length($b=$'), 2;		# 21
+    $test++;
 
-    {
-	use bytes;
+    ok length($b=$1), 1;		# 22
+    $test++;
 
-	my $tmp = $&;
-	ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272);
-	$test++;				# 23
+    ok $a, "\x{263A}";			# 23
+    $test++;
 
-	$tmp = $';
-	ok $tmp, pack("C*", 0342, 0230, 0272);
-	$test++;				# 24
+    ok $`, "\x{263A}\x{263A}";		# 24
+    $test++;
 
-	$tmp = $`;
-	ok $tmp, pack("C*", 0342, 0230, 0272);
-	$test++;				# 25
+    ok $&, "x\x{263A}";			# 25
+    $test++;
 
-	$tmp = $1;
-	ok $tmp, pack("C*", 0342, 0230, 0272);
-	$test++;				# 26
-    }
+    ok $', "y\x{263A}";			# 26
+    $test++;
 
-    ok_bytes $&, pack("C*", ord(">"), 0342, 0230, 0272);
-    $test++;				# 27
+    ok $1, "\x{263A}";			# 27
+    $test++;
 
-    ok_bytes $', pack("C*", 0342, 0230, 0272);
-    $test++;				# 28
+    ok_bytes $a, "\342\230\272";	# 28
+    $test++;
 
-    ok_bytes $`, pack("C*", 0342, 0230, 0272);
-    $test++;				# 29
+    ok_bytes $1, "\342\230\272";	# 29
+    $test++;
 
-    ok_bytes $1, pack("C*", 0342, 0230, 0272);
-    $test++;				# 30
+    ok_bytes $&, "x\342\230\272";	# 30
+    $test++;
 
     {
-	use bytes;
-	no utf8;
-
-	ok length, 10;
-	$test++;				# 31
-
-    	ok length((m/>(.)/)[0]), 1;
-    	$test++;				# 32
-
-    	ok length($&), 2;
-    	$test++;				# 33
+	use utf8; # required
+	$_ = chr(0x263A) . chr(0x263A) . 'x' . chr(0x263A) . 'y' . chr(0x263A);
+    }
 
-    	ok length($'), 5;
-    	$test++;				# 34
+    ok length($_), 6;			# 31
+    $test++;
 
-    	ok length($`), 3;
-    	$test++;				# 35
+    ($a) = m/x(.)/;
 
-    	ok length($1), 1;
-    	$test++;				# 36
+    ok length($a), 1;			# 32
+    $test++;
 
-	ok $&, pack("C*", ord(">"), 0342);
-	$test++;				# 37
+    ok length($`), 2;			# 33
+    $test++;
 
-	ok $', pack("C*", 0230, 0272, 0342, 0230, 0272);
-	$test++;				# 38
+    ok length($&), 2;			# 34
+    $test++;
 
-	ok $`, pack("C*", 0342, 0230, 0272);
-	$test++;				# 39
+    ok length($'), 2;			# 35
+    $test++;
 
-	ok $1, pack("C*", 0342);
-	$test++;				# 40
+    ok length($1), 1;			# 36
+    $test++;
 
-    }
+    ok length($b=$`), 2;		# 37
+    $test++;
 
+    ok length($b=$&), 2;		# 38
+    $test++;
 
-    {
-	no utf8;
-	$_="\342\230\272>\342\230\272\342\230\272";
-    }
+    ok length($b=$'), 2;		# 39
+    $test++;
 
-    ok length, 10;
-    $test++;				# 41
+    ok length($b=$1), 1;		# 40
+    $test++;
 
-    ok length((m/>(.)/)[0]), 1;
-    $test++;				# 42
+    ok $a, "\x{263A}";			# 41
+    $test++;
 
-    ok length($&), 2;
-    $test++;				# 43
+    ok $`, "\x{263A}\x{263A}";		# 42
+    $test++;
 
-    ok length($'), 1;
-    $test++;				# 44
+    ok $&, "x\x{263A}";			# 43
+    $test++;
 
-    ok length($`), 1;
-    $test++;				# 45
+    ok $', "y\x{263A}";			# 44
+    $test++;
 
-    ok length($1), 1;
-    $test++;				# 46
+    ok $1, "\x{263A}";			# 45
+    $test++;
 
-    ok length($tmp=$&), 2;
-    $test++;				# 47
+    ok_bytes $a, "\342\230\272";	# 46
+    $test++;
 
-    ok length($tmp=$'), 1;
-    $test++;				# 48
+    ok_bytes $1, "\342\230\272";	# 47
+    $test++;
 
-    ok length($tmp=$`), 1;
-    $test++;				# 49
+    ok_bytes $&, "x\342\230\272";	# 48
+    $test++;
 
-    ok length($tmp=$1), 1;
-    $test++;				# 50
+    $_ = "\342\230\272\342\230\272x\342\230\272y\342\230\272";
 
-    {
-	use bytes;
+    ok length($_), 14;			# 49
+    $test++;
 
-        my $tmp = $&;
-	ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272);
-	$test++;				# 51
+    ($a) = m/x(.)/;
 
-        $tmp = $';
-	ok $tmp, pack("C*", 0342, 0230, 0272);
-	$test++;				# 52
+    ok length($a), 1;			# 50
+    $test++;
 
-        $tmp = $`;
-	ok $tmp, pack("C*", 0342, 0230, 0272);
-	$test++;				# 53
+    ok length($`), 6;			# 51
+    $test++;
 
-        $tmp = $1;
-	ok $tmp, pack("C*", 0342, 0230, 0272);
-	$test++;				# 54
-    }
-    {
-	use bytes;
-	no utf8;
+    ok length($&), 2;			# 52
+    $test++;
 
-	ok length, 10;
-	$test++;				# 55
+    ok length($'), 6;			# 53
+    $test++;
 
-    	ok length((m/>(.)/)[0]), 1;
-    	$test++;				# 56
+    ok length($1), 1;			# 54
+    $test++;
 
-    	ok length($&), 2;
-    	$test++;				# 57
+    ok length($b=$`), 6;		# 55
+    $test++;
 
-    	ok length($'), 5;
-    	$test++;				# 58
+    ok length($b=$&), 2;		# 56
+    $test++;
 
-    	ok length($`), 3;
-    	$test++;				# 59
+    ok length($b=$'), 6;		# 57
+    $test++;
 
-    	ok length($1), 1;
-    	$test++;				# 60
+    ok length($b=$1), 1;		# 58
+    $test++;
 
-	ok $&, pack("C*", ord(">"), 0342);
-	$test++;				# 61
+    ok $a, "\342";			# 59
+    $test++;
 
-	ok $', pack("C*", 0230, 0272, 0342, 0230, 0272);
-	$test++;				# 62
+    ok $`, "\342\230\272\342\230\272";	# 60
+    $test++;
 
-	ok $`, pack("C*", 0342, 0230, 0272);
-	$test++;				# 63
+    ok $&, "x\342";			# 61
+    $test++;
 
-	ok $1, pack("C*", 0342);
-	$test++;				# 64
+    ok $', "\230\272y\342\230\272";	# 62
+    $test++;
 
-    }
+    ok $1, "\342";			# 63
+    $test++;
+}
 
+{
+    use utf8;
     ok "\x{ab}" =~ /^\x{ab}$/, 1;
-    $test++;					# 65
+    $test++;				# 64
 }
 
 {
     use utf8;
     ok_bytes chr(0xe2), pack("C*", 0xc3, 0xa2);
-    $test++;                # 66
+    $test++;                # 65
 }
 
 {
     use utf8;
     my @a = map ord, split(//, join("", map chr, (1234, 123, 2345)));
     ok "@a", "1234 123 2345";
-    $test++;                # 67
+    $test++;                # 66
 }
 
 {
@@ -320,17 +299,22 @@ sub nok_bytes {
     my $x = chr(123);
     my @a = map ord, split(/$x/, join("", map chr, (1234, 123, 2345)));
     ok "@a", "1234 2345";
-    $test++;                # 68
+    $test++;                # 67
 }
 
 {
     # bug id 20001009.001
 
-    my($a,$b);
-    { use bytes; $a = "\xc3\xa4"; }  
-    { use utf8;  $b = "\xe4"; }
-    { use bytes; ok_bytes $a, $b; $test++; } # 69
-    { use utf8;  nok      $a, $b; $test++; } # 70
+    my ($a, $b);
+
+    { use bytes; $a = "\xc3\xa4" }
+    { use utf8;  $b = "\xe4"     } # \xXX must not produce UTF-8
+
+    print "not " if $a eq $b;
+    print "ok $test\n"; $test++;	# 68
+
+    { use utf8; print "not " if $a eq $b; }
+    print "ok $test\n"; $test++;	# 69
 }
 
 {
@@ -340,7 +324,7 @@ sub nok_bytes {
     for (@x) {
 	s/(\d+)\s*([\w\-]+)/$1 . uc $2/e;
 	my($latin) = /^(.+)(?:\s+\d)/;
-	print $latin eq "stra\337e" ? "ok $test\n" :
+	print $latin eq "stra\337e" ? "ok $test\n" :	# 70, 71
 	    "#latin[$latin]\nnot ok $test\n";
 	$test++;
 	$latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a
@@ -350,64 +334,6 @@ sub nok_bytes {
 }
 
 {
-    # bug id 20000819.004 
-
-    $_ = $dx = "\x{10f2}";
-    s/($dx)/$dx$1/;
-    {
-	use bytes;
-	print "not " unless $_ eq "$dx$dx";
-	print "ok $test\n";
-	$test++;
-    }
-
-    $_ = $dx = "\x{10f2}";
-    s/($dx)/$1$dx/;
-    {
-	use bytes;
-	print "not " unless $_ eq "$dx$dx";
-	print "ok $test\n";
-	$test++;
-    }
-
-    $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++;
-    }
-}
-
-{
-    # bug id 20000323.056
-
-    use utf8;
-
-    print "not " unless "\x{41}" eq +v65;
-    print "ok $test\n";
-    $test++;
-
-    print "not " unless "\x41" eq +v65;
-    print "ok $test\n";
-    $test++;
-
-    print "not " unless "\x{c8}" eq +v200;
-    print "ok $test\n";
-    $test++;
-
-    print "not " unless "\xc8" eq +v200;
-    print "ok $test\n";
-    $test++;
-
-    print "not " unless "\x{221b}" eq v8731;
-    print "ok $test\n";
-    $test++;
-}
-
-{
     # bug id 20000427.003 
 
     use utf8;
@@ -423,18 +349,7 @@ sub nok_bytes {
     }
 
     print "not " unless $r eq " U+B36C U+5A8C U+FF5B U+5079 U+505B";
-    print "ok $test\n";
-    $test++;
-}
-
-{
-    # bug id 20000901.092
-    # test that undef left and right of utf8 results in a valid string
-
-    my $a;
-    $a .= "\x{1ff}";
-    print "not " unless $a eq "\x{1ff}";
-    print "ok $test\n";
+    print "ok $test\n";			# 72
     $test++;
 }
 
@@ -449,27 +364,27 @@ sub nok_bytes {
     print "not "
 	unless $a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a;
     print "ok $test\n";
-    $test++;
+    $test++;				# 73
 
     my ($a, $b) = split(/\x{100}/, $s);
     print "not " unless $a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20";
     print "ok $test\n";
-    $test++;
+    $test++;				# 74
 
     my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s);
     print "not " unless $a eq "\x20\x40" && $b eq "\x40\x20";
     print "ok $test\n";
-    $test++;
+    $test++;				# 75
 
     my ($a, $b) = split(/\x40\x{80}/, $s);
     print "not " unless $a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20";
     print "ok $test\n";
-    $test++;
+    $test++;				# 76
 
     my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s);
     print "not " unless $a eq "\x20" && $b eq "\x{100}" && $c eq "\x20";
     print "ok $test\n";
-    $test++;
+    $test++;				# 77
 }
 
 {
@@ -479,14 +394,14 @@ sub nok_bytes {
 
     my $smiley = "\x{263a}";
 
-    for my $s ("\x{263a}",                     #  1
-	       $smiley,                        #  2
+    for my $s ("\x{263a}",                     # 78
+	       $smiley,                        # 79
 		
-	       "" . $smiley,                   #  3
-	       "" . "\x{263a}",                #  4
+	       "" . $smiley,                   # 80
+	       "" . "\x{263a}",                # 81
 
-	       $smiley    . "",                #  5
-	       "\x{263a}" . "",                #  6
+	       $smiley    . "",                # 82
+	       "\x{263a}" . "",                # 83
 	       ) {
 	my $length_chars = length($s);
 	my $length_bytes;
@@ -502,14 +417,14 @@ sub nok_bytes {
 	$test++;
     }
 
-    for my $s ("\x{263a}" . "\x{263a}",        #  7
-	       $smiley    . $smiley,           #  8
+    for my $s ("\x{263a}" . "\x{263a}",        # 84
+	       $smiley    . $smiley,           # 85
 
-	       "\x{263a}\x{263a}",             #  9
-	       "$smiley$smiley",               # 10
+	       "\x{263a}\x{263a}",             # 86
+	       "$smiley$smiley",               # 87
 	       
-	       "\x{263a}" x 2,                 # 11
-	       $smiley    x 2,                 # 12
+	       "\x{263a}" x 2,                 # 88
+	       $smiley    x 2,                 # 89
 	       ) {
 	my $length_chars = length($s);
 	my $length_bytes;
@@ -525,3 +440,117 @@ sub nok_bytes {
 	$test++;
     }
 }
+
+{
+    use utf8;
+
+    print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\xd4";
+    print "ok $test\n";
+    $test++;					# 90
+
+    print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}";
+    print "ok $test\n";
+    $test++;					# 91
+
+    print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}";
+    print "ok $test\n";
+    $test++;					# 92
+
+    print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\xd4";
+    print "ok $test\n";
+    $test++;					# 93
+
+    print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4";
+    print "ok $test\n";
+    $test++;					# 94
+
+    print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}";
+    print "ok $test\n";
+    $test++;					# 95
+
+    print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}";
+    print "ok $test\n";
+    $test++;					# 96
+
+    print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4";
+    print "ok $test\n";
+    $test++;					# 97
+}
+
+{
+    # the first half of 20001028.003
+
+    my $X = chr(1448);
+    my ($Y) = $X =~ /(.*)/;
+    print "not " unless length $Y == 1;
+    print "ok $test\n";
+    $test++;					# 98
+}
+
+{
+    # 20001108.001
+
+    use utf8;
+    my $X = "Szab\x{f3},Bal\x{e1}zs";
+    my $Y = $X;
+    $Y =~ s/(B)/$1/ for 0..3;
+    print "not " unless $Y eq $X;
+    print "ok $test\n";
+    $test++;					# 99
+}
+
+{
+    # 20001114.001	
+
+    use utf8;
+    use charnames ':full';
+    my $text = "\N{LATIN CAPITAL LETTER A WITH DIAERESIS}";
+    print "not " unless ord($text) == 0xc4;
+    print "ok $test\n";
+    $test++;                                    # 100
+}
+
+{
+    # 20001205.014
+
+    use utf8;
+
+    my $a = "ABC\x{263A}";
+
+    my @b = split( //, $a );
+
+    print "not " unless @b == 4;
+    print "ok $test\n";
+    $test++;                                    # 101
+
+    print "not " unless length($b[3]) == 1;
+    print "ok $test\n";
+    $test++;                                    # 102
+
+    $a =~ s/^A/Z/;
+    print "not " unless length($a) == 4;
+    print "ok $test\n";
+    $test++;                                    # 103
+}
+
+{
+    # the second half of 20001028.003
+
+    use utf8;
+    $X =~ s/^/chr(1488)/e;
+    print "not " unless length $X == 1;
+    print "ok $test\n";
+    $test++;					# 104
+}
+
+{
+    # 20000517.001
+
+    my $x = "\x{100}A";
+
+    $x =~ s/A/B/;
+
+    print "not " unless $x eq "\x{100}B" && length($x) == 2;
+    print "ok $test\n";
+    $test++;					# 105
+}
diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot
index 426820550c..5dd03801e1 100644
--- a/t/pragma/warn/pp_hot
+++ b/t/pragma/warn/pp_hot
@@ -47,6 +47,9 @@
   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' ;
@@ -151,6 +154,7 @@ open (FH, ">./xcv") ;
 my $a = <FH> ;
 no warnings 'io' ;
 $a = <FH> ;
+close (FH) ;
 unlink $file ;
 EXPECT
 Filehandle FH opened only for output at - line 5.
@@ -227,3 +231,17 @@ $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.
diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys
index 2843c70ed3..e30637b0d4 100644
--- a/t/pragma/warn/pp_sys
+++ b/t/pragma/warn/pp_sys
@@ -3,6 +3,15 @@
   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 =
     .
@@ -74,7 +83,7 @@
     flock STDIN, 8;
     flock $a, 8;
 
-  lstat() on filehandle %s			[pp_stat]
+  The stat preceding lstat() wasn't an lstat %s	[pp_stat]
     lstat(STDIN);
 
   warn(warn_nl, "stat");			[pp_stat]
@@ -203,7 +212,9 @@ syswrite() on closed filehandle STDIN at - line 6.
 # pp_sys.c [pp_flock]
 use Config; 
 BEGIN { 
-  if ( $^O eq 'VMS' and ! $Config{d_flock}) {
+  if ( !$Config{d_flock} &&
+       !$Config{d_fcntl_can_lock} &&
+       !$Config{d_lockf} ) {
     print <<EOM ;
 SKIPPED
 # flock not present
@@ -225,11 +236,11 @@ flock STDIN, 8;
 flock FOO, 8;
 flock $a, 8;
 EXPECT
-flock() on closed filehandle STDIN at - line 14.
 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 17.
-flock() on unopened filehandle at - line 18.
+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' ;
@@ -352,7 +363,7 @@ lstat(STDIN) ;
 no warnings 'io' ;
 lstat(STDIN) ;
 EXPECT
-lstat() on filehandle STDIN at - line 13.
+The stat preceding lstat() wasn't an lstat at - line 13.
 ########
 # pp_sys.c [pp_fttext]
 use warnings qw(unopened closed) ;
@@ -398,3 +409,11 @@ 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.
diff --git a/t/pragma/warn/utf8 b/t/pragma/warn/utf8
index 6a2fe5446c..9a7dbafdee 100644
--- a/t/pragma/warn/utf8
+++ b/t/pragma/warn/utf8
@@ -15,6 +15,12 @@
 
 __END__
 # utf8.c [utf8_to_uv] -W
+BEGIN {
+    if (ord('A') == 193) {
+        print "SKIPPED\n# ebcdic platforms do not generate Malformed UTF-8 warnings.";
+        exit 0;
+    }
+}
 use utf8 ;
 my $a = "snøstorm" ;
 {
@@ -24,6 +30,6 @@ my $a = "snøstorm" ;
     my $a = "snøstorm";
 }
 EXPECT
-Malformed UTF-8 character at - line 3.
-Malformed UTF-8 character at - line 8.
+Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 9.
+Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 14.
 ########
diff --git a/t/pragma/warnings.t b/t/pragma/warnings.t
index 367449797d..872e6e1417 100644
--- a/t/pragma/warnings.t
+++ b/t/pragma/warnings.t
@@ -25,28 +25,37 @@ if (@ARGV)
 else
   { @w_files = sort glob("pragma/warn/*") }
 
-foreach (@w_files) {
+my $files = 0;
+foreach my $file (@w_files) {
 
     next if /(~|\.orig|,v)$/;
 
-    open F, "<$_" or die "Cannot open $_: $!\n" ;
+    open F, "<$file" or die "Cannot open $file: $!\n" ;
+    my $line = 0;
     while (<F>) {
+        $line++; 
 	last if /^__END__/ ;
     }
 
     {
         local $/ = undef;
-        @prgs = (@prgs, split "\n########\n", <F>) ;
+        $files++; 
+        @prgs = (@prgs, $file, split "\n########\n", <F>) ;
     }
     close F ;
 }
 
 undef $/;
 
-print "1..", scalar @prgs, "\n";
+print "1..", scalar(@prgs)-$files, "\n";
  
  
 for (@prgs){
+    unless (/\n/)
+     {
+      print "# From $_\n"; 
+      next; 
+     }
     my $switch = "";
     my @temps = () ;
     if (s/^\s*-\w+//){