Import perl-5.28.1

looking good sthen@, Great! bluhm@

86 files changed, 3686 insertions, 344 deletions

diff --git a/gnu/usr.bin/perl/ext/B/B/Terse.pm b/gnu/usr.bin/perl/ext/B/B/Terse.pm
index 8e551c5a62f..681112e9041 100644
--- a/gnu/usr.bin/perl/ext/B/B/Terse.pm
+++ b/gnu/usr.bin/perl/ext/B/B/Terse.pm
@@ -1,6 +1,6 @@
 package B::Terse;
 
-our $VERSION = '1.06';
+our $VERSION = '1.08';
 
 use strict;
 use B qw(class @specialsv_name);
@@ -30,12 +30,6 @@ sub indent {
     return "    " x $level;
 }
 
-# Don't use this, at least on OPs in subroutines: it has no way of
-# getting to the pad, and will give wrong answers or crash.
-sub B::OP::terse {
-    carp "B::OP::terse is deprecated; use B::Concise instead";
-    B::Concise::b_terse(@_);
-}
 
 sub B::SV::terse {
     my($sv, $level) = (@_, 0);
diff --git a/gnu/usr.bin/perl/ext/B/B/Xref.pm b/gnu/usr.bin/perl/ext/B/B/Xref.pm
index 8beb243f71f..000790a2694 100644
--- a/gnu/usr.bin/perl/ext/B/B/Xref.pm
+++ b/gnu/usr.bin/perl/ext/B/B/Xref.pm
@@ -1,6 +1,6 @@
 package B::Xref;
 
-our $VERSION = '1.05';
+our $VERSION = '1.07';
 
 =head1 NAME
 
@@ -143,7 +143,7 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 use strict;
 use Config;
 use B qw(peekop class comppadlist main_start svref_2object walksymtable
-         OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring
+         OPpLVAL_INTRO SVf_POK SVf_ROK OPpOUR_INTRO cstring
         );
 
 sub UNKNOWN { ["?", "?", "?"] }
@@ -331,7 +331,13 @@ sub pp_gv {
     }
     else {
 	$gv = $op->gv;
-	$top = [$gv->STASH->NAME, "*", $gv->SAFENAME];
+	if ($gv->FLAGS & SVf_ROK) { # sub ref
+	    my $cv = $gv->RV;
+	    $top = [$cv->STASH->NAME, '*', B::safename($cv->NAME_HEK)]
+	}
+	else {
+	    $top = [$gv->STASH->NAME, '*', $gv->SAFENAME];
+	}
     }
     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 }
@@ -449,7 +455,7 @@ sub compile {
 	    last OPTION;
 	} elsif ($opt eq "o") {
 	    $arg ||= shift @options;
-	    open(STDOUT, ">$arg") or return "$arg: $!\n";
+	    open(STDOUT, '>', $arg) or return "$arg: $!\n";
 	} elsif ($opt eq "d") {
 	    $nodefs = 1;
 	} elsif ($opt eq "r") {
diff --git a/gnu/usr.bin/perl/ext/B/O.pm b/gnu/usr.bin/perl/ext/B/O.pm
index 2976a894208..81c879835bc 100644
--- a/gnu/usr.bin/perl/ext/B/O.pm
+++ b/gnu/usr.bin/perl/ext/B/O.pm
@@ -1,16 +1,18 @@
 package O;
 
-our $VERSION = '1.01';
+our $VERSION = '1.03';
 
-use B qw(minus_c save_BEGINs);
-use Carp;
+use B ();
+
+our $BEGIN_output;
+our $saveout_fh;
 
 sub import {
     my ($class, @options) = @_;
     my ($quiet, $veryquiet) = (0, 0);
     if ($options[0] eq '-q' || $options[0] eq '-qq') {
 	$quiet = 1;
-	open (SAVEOUT, ">&STDOUT");
+	open ($saveout_fh, ">&", STDOUT);
 	close STDOUT;
 	open (STDOUT, ">", \$O::BEGIN_output);
 	if ($options[0] eq '-qq') {
@@ -21,15 +23,15 @@ sub import {
     my $backend = shift (@options);
     eval q[
 	BEGIN {
-	    minus_c;
-	    save_BEGINs;
+	    B::minus_c;
+	    B::save_BEGINs;
 	}
 
 	CHECK {
 	    if ($quiet) {
 		close STDOUT;
-		open (STDOUT, ">&SAVEOUT");
-		close SAVEOUT;
+		open (STDOUT, ">&", $saveout_fh);
+		close $saveout_fh;
 	    }
 
 	    # Note: if you change the code after this 'use', please
@@ -37,10 +39,6 @@ sub import {
 	    # "fragile kludge") so that its output still looks
 	    # nice. Thanks. --smcc
 	    use B::].$backend.q[ ();
-	    if ($@) {
-		croak "use of backend $backend failed: $@";
-	    }
-
 
 	    my $compilesub = &{"B::${backend}::compile"}(@options);
 	    if (ref($compilesub) ne "CODE") {
@@ -54,7 +52,11 @@ sub import {
 	    close STDERR if $veryquiet;
 	}
     ];
-    die $@ if $@;
+    if ($@) {
+        my $msg = "$@";
+        require Carp;
+        Carp::croak("Loading compiler backend 'B::$backend' failed: $msg");
+    }
 }
 
 1;
diff --git a/gnu/usr.bin/perl/ext/B/t/f_sort b/gnu/usr.bin/perl/ext/B/t/f_sort
index 759523bb70f..75e8f105964 100644
--- a/gnu/usr.bin/perl/ext/B/t/f_sort
+++ b/gnu/usr.bin/perl/ext/B/t/f_sort
@@ -68,10 +68,6 @@ sub other::backwards ($$) { $_[1] cmp $_[0]; }
 use sort 'stable';
 @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;
 
-# force use of mergesort (not portable outside Perl 5.8)
-use sort '_mergesort';
-@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;
-
 # you should have a good reason to do this!
 @articles = sort {$FooPack::b <=> $FooPack::a} @files;
 
diff --git a/gnu/usr.bin/perl/ext/B/t/optree_constants.t b/gnu/usr.bin/perl/ext/B/t/optree_constants.t
index 865eed1df06..a8073164dbc 100644
--- a/gnu/usr.bin/perl/ext/B/t/optree_constants.t
+++ b/gnu/usr.bin/perl/ext/B/t/optree_constants.t
@@ -16,10 +16,21 @@ BEGIN {
 use OptreeCheck;	# ALSO DOES @ARGV HANDLING !!!!!!
 use Config;
 
-plan tests => 67;
+plan tests => 99;
 
 #################################
 
+my sub lleexx {}
+sub tsub0 {}
+sub tsub1 {} $tsub1 = 1;
+sub t::tsub2 {}
+sub t::tsub3 {} $tsub3 = 1;
+{
+    package t;
+    sub tsub4 {}
+    sub tsub5 {} $tsub5 = 1;
+}
+
 use constant {		# see also t/op/gv.t line 358
     myaref	=> [ 1,2,3 ],
     myfl	=> 1.414213,
@@ -31,32 +42,42 @@ use constant {		# see also t/op/gv.t line 358
     mysub	=> \&ok,
     myundef	=> undef,
     myunsub	=> \&nosuch,
+    myanonsub	=> sub {},
+    mylexsub	=> \&lleexx,
+    tsub0	=> \&tsub0,
+    tsub1	=> \&tsub1,
+    tsub2	=> \&t::tsub2,
+    tsub3	=> \&t::tsub3,
+    tsub4	=> \&t::tsub4,
+    tsub5	=> \&t::tsub5,
 };
 
 sub myyes() { 1==1 }
 sub myno () { return 1!=1 }
 sub pi () { 3.14159 };
 
-my $RV_class = $] >= 5.011 ? 'IV' : 'RV';
-
 my $want = {	# expected types, how value renders in-line, todos (maybe)
     mystr	=> [ 'PV', '"'.mystr.'"' ],
-    myhref	=> [ $RV_class, '\\\\HASH'],
+    myhref	=> [ 'IV', '\\\\HASH'],
     pi		=> [ 'NV', pi ],
-    myglob	=> [ $RV_class, '\\\\' ],
-    mysub	=> [ $RV_class, '\\\\' ],
-    myunsub	=> [ $RV_class, '\\\\' ],
+    myglob	=> [ 'IV', '\\\\' ],
+    mysub	=> [ 'IV', '\\\\&main::ok' ],
+    myunsub	=> [ 'IV', '\\\\&main::nosuch' ],
+    myanonsub	=> [ 'IV', '\\\\CODE' ],
+    mylexsub	=> [ 'IV', '\\\\&lleexx' ],
+    tsub0	=> [ 'IV', '\\\\&main::tsub0' ],
+    tsub1	=> [ 'IV', '\\\\&main::tsub1' ],
+    tsub2	=> [ 'IV', '\\\\&t::tsub2' ],
+    tsub3	=> [ 'IV', '\\\\&t::tsub3' ],
+    tsub4	=> [ 'IV', '\\\\&t::tsub4' ],
+    tsub5	=> [ 'IV', '\\\\&t::tsub5' ],
     # these are not inlined, at least not per BC::Concise
-    #myyes	=> [ $RV_class, ],
-    #myno	=> [ $RV_class, ],
-    myaref	=> [ $RV_class, '\\\\' ],
+    #myyes	=> [ 'IV', ],
+    #myno	=> [ 'IV', ],
+    myaref	=> [ 'IV', '\\\\ARRAY' ],
     myfl	=> [ 'NV', myfl ],
     myint	=> [ 'IV', myint ],
-    $] >= 5.011 ? (
-    myrex	=> [ $RV_class, '\\\\"\\(?^:Foo\\)"' ],
-    ) : (
-    myrex	=> [ $RV_class, '\\\\' ],
-    ),
+    myrex	=> [ 'IV', '\\\\"\\(?^:Foo\\)"' ],
     myundef	=> [ 'NULL', ],
 };
 
@@ -102,14 +123,12 @@ for $func (sort keys %$want) {
 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 -     <\@> lineseq KP ->3
 1        <;> dbstate(main 833 (eval 44):1) v ->2
-2        <\$> const[$want->{$func}[0] $want->{$func}[1]] s* ->3      < 5.017002
-2        <\$> const[$want->{$func}[0] $want->{$func}[1]] s*/FOLD ->3 >=5.017002
+2        <\$> const[$want->{$func}[0] $want->{$func}[1]] s*/FOLD ->3
 EOT_EOT
 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 -     <\@> lineseq KP ->3
 1        <;> dbstate(main 833 (eval 44):1) v ->2
-2        <\$> const($want->{$func}[0] $want->{$func}[1]) s* ->3      < 5.017002
-2        <\$> const($want->{$func}[0] $want->{$func}[1]) s*/FOLD ->3 >=5.017002
+2        <\$> const($want->{$func}[0] $want->{$func}[1]) s*/FOLD ->3
 EONT_EONT
 
 }
@@ -137,16 +156,14 @@ checkOptree ( name	=> 'myyes() as coderef',
 # 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
 # 5     <@> print vK ->6
 # 3        <0> pushmark s ->4
-# 4        <$> const[SPECIAL sv_yes] s* ->5         < 5.017002
-# 4        <$> const[SPECIAL sv_yes] s*/FOLD ->5    >=5.017002
+# 4        <$> const[SPECIAL sv_yes] s*/FOLD ->5
 EOT_EOT
 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 # 1     <0> enter ->2
 # 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
 # 5     <@> print vK ->6
 # 3        <0> pushmark s ->4
-# 4        <$> const(SPECIAL sv_yes) s* ->5         < 5.017002
-# 4        <$> const(SPECIAL sv_yes) s*/FOLD ->5    >=5.017002
+# 4        <$> const(SPECIAL sv_yes) s*/FOLD ->5
 EONT_EONT
 
 
@@ -163,33 +180,18 @@ checkOptree ( name	=> 'myno() as coderef',
 # 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
 # 5     <@> print vK ->6
 # 3        <0> pushmark s ->4
-# 4        <$> const[SPECIAL sv_no] s* ->5         < 5.017002
-# 4        <$> const[SPECIAL sv_no] s*/FOLD ->5    >=5.017002
+# 4        <$> const[SPECIAL sv_no] s*/FOLD ->5
 EOT_EOT
 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 # 1     <0> enter ->2
 # 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
 # 5     <@> print vK ->6
 # 3        <0> pushmark s ->4
-# 4        <$> const(SPECIAL sv_no) s* ->5         < 5.017002
-# 4        <$> const(SPECIAL sv_no) s*/FOLD ->5    >=5.017002
+# 4        <$> const(SPECIAL sv_no) s*/FOLD ->5
 EONT_EONT
 
 
-my ($expect, $expect_nt) =
-    $] >= 5.019003
-	? (" is a constant sub, optimized to a AV\n") x 2
-	: (<<'EOT_EOT', <<'EONT_EONT');
-# 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
-# -     <@> lineseq K ->3
-# 1        <;> nextstate(constant 61 constant.pm:118) v:*,&,x*,x&,x$ ->2
-# 2        <0> padav[@list:FAKE:m:96] ->3
-EOT_EOT
-# 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
-# -     <@> lineseq K ->3
-# 1        <;> nextstate(constant 61 constant.pm:118) v:*,&,x*,x&,x$ ->2
-# 2        <0> padav[@list:FAKE:m:71] ->3
-EONT_EONT
+my ($expect, $expect_nt) = (" is a constant sub, optimized to a AV\n") x 2;
 
 
 checkOptree ( name	=> 'constant sub returning list',
@@ -210,14 +212,10 @@ my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
 # 8        <@> prtf sK ->9
 # 2           <0> pushmark sM ->3
 # 3           <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] sM/FOLD ->4
-# 4           <$> const[IV 42] sM* ->5          < 5.017002
-# 5           <$> const[PV "hithere"] sM* ->6   < 5.017002
-# 6           <$> const[NV 1.414213] sM* ->7    < 5.017002
-# 7           <$> const[NV 3.14159] sM* ->8     < 5.017002
-# 4           <$> const[IV 42] sM*/FOLD ->5          >=5.017002 
-# 5           <$> const[PV "hithere"] sM*/FOLD ->6   >=5.017002
-# 6           <$> const[NV 1.414213] sM*/FOLD ->7    >=5.017002
-# 7           <$> const[NV 3.14159] sM*/FOLD ->8     >=5.017002
+# 4           <$> const[IV 42] sM*/FOLD ->5
+# 5           <$> const[PV "hithere"] sM*/FOLD ->6
+# 6           <$> const[NV 1.414213] sM*/FOLD ->7
+# 7           <$> const[NV 3.14159] sM*/FOLD ->8
 EOT_EOT
 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 # -     <@> lineseq KP ->9
@@ -225,22 +223,13 @@ EOT_EOT
 # 8        <@> prtf sK ->9
 # 2           <0> pushmark sM ->3
 # 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") sM/FOLD ->4
-# 4           <$> const(IV 42) sM* ->5          < 5.017002
-# 5           <$> const(PV "hithere") sM* ->6   < 5.017002
-# 6           <$> const(NV 1.414213) sM* ->7    < 5.017002
-# 7           <$> const(NV 3.14159) sM* ->8     < 5.017002
-# 4           <$> const(IV 42) sM*/FOLD ->5          >=5.017002 
-# 5           <$> const(PV "hithere") sM*/FOLD ->6   >=5.017002
-# 6           <$> const(NV 1.414213) sM*/FOLD ->7    >=5.017002
-# 7           <$> const(NV 3.14159) sM*/FOLD ->8     >=5.017002
+# 4           <$> const(IV 42) sM*/FOLD ->5
+# 5           <$> const(PV "hithere") sM*/FOLD ->6
+# 6           <$> const(NV 1.414213) sM*/FOLD ->7
+# 7           <$> const(NV 3.14159) sM*/FOLD ->8
 EONT_EONT
 
-if($] < 5.015) {
-    s/M(?=\*? ->)//g for $expect, $expect_nt;
-}
-if($] < 5.017002 || $] >= 5.019004) {
-    s|\\n"[])] sM\K/FOLD|| for $expect, $expect_nt;
-}
+s|\\n"[])] sM\K/FOLD|| for $expect, $expect_nt;
 
 checkOptree ( name	=> 'call many in a print statement',
 	      code	=> \&printem,
@@ -258,16 +247,14 @@ checkOptree ( name	=> 'arithmetic constant folding in print',
 # 1        <;> nextstate(main 937 (eval 53):1) v ->2
 # 4        <@> print sK ->5
 # 2           <0> pushmark s ->3
-# 3           <$> const[IV 6] s ->4      < 5.017002
-# 3           <$> const[IV 6] s/FOLD ->4 >=5.017002
+# 3           <$> const[IV 6] s/FOLD ->4
 EOT_EOT
 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 # -     <@> lineseq KP ->5
 # 1        <;> nextstate(main 937 (eval 53):1) v ->2
 # 4        <@> print sK ->5
 # 2           <0> pushmark s ->3
-# 3           <$> const(IV 6) s ->4      < 5.017002
-# 3           <$> const(IV 6) s/FOLD ->4 >=5.017002
+# 3           <$> const(IV 6) s/FOLD ->4
 EONT_EONT
 
 checkOptree ( name	=> 'string constant folding in print',
@@ -279,16 +266,14 @@ checkOptree ( name	=> 'string constant folding in print',
 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
 # 4        <@> print sK ->5
 # 2           <0> pushmark s ->3
-# 3           <$> const[PV "foobar"] s ->4      < 5.017002
-# 3           <$> const[PV "foobar"] s/FOLD ->4 >=5.017002
+# 3           <$> const[PV "foobar"] s/FOLD ->4
 EOT_EOT
 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 # -     <@> lineseq KP ->5
 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
 # 4        <@> print sK ->5
 # 2           <0> pushmark s ->3
-# 3           <$> const(PV "foobar") s ->4      < 5.017002
-# 3           <$> const(PV "foobar") s/FOLD ->4 >=5.017002
+# 3           <$> const(PV "foobar") s/FOLD ->4
 EONT_EONT
 
 checkOptree ( name	=> 'boolean or folding',
@@ -298,16 +283,14 @@ checkOptree ( name	=> 'boolean or folding',
 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 # -     <@> lineseq KP ->5
 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
-# 4        <@> print sK ->5      < 5.019004
-# 4        <@> print sK/FOLD ->5 >=5.019004
+# 4        <@> print sK/FOLD ->5
 # 2           <0> pushmark s ->3
 # 3           <$> const[PV "foobar"] s ->4
 EOT_EOT
 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 # -     <@> lineseq KP ->5
 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
-# 4        <@> print sK ->5      < 5.019004
-# 4        <@> print sK/FOLD ->5 >=5.019004
+# 4        <@> print sK/FOLD ->5
 # 2           <0> pushmark s ->3
 # 3           <$> const(PV "foobar") s ->4
 EONT_EONT
@@ -328,76 +311,61 @@ checkOptree ( name	=> 'lc*,uc*,gt,lt,ge,le,cmp',
 # -     <@> lineseq KP ->r
 # 1        <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
 # 4        <2> sassign vKS/2 ->5
-# 2           <$> const[PV "FOO.Bar.low.lOW"] s ->3      < 5.017002
-# 2           <$> const[PV "FOO.Bar.low.lOW"] s/FOLD ->3 >=5.017002
+# 2           <$> const[PV "FOO.Bar.low.lOW"] s/FOLD ->3
 # -           <1> ex-rv2sv sKRM*/1 ->4
 # 3              <#> gvsv[*s] s ->4
 # 5        <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
-# 8        <@> print vK ->9      < 5.019004
-# 8        <@> print vK/FOLD ->9 >=5.019004
+# 8        <@> print vK/FOLD ->9
 # 6           <0> pushmark s ->7
 # 7           <$> const[PV "a-lt-b"] s ->8
 # 9        <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
-# c        <@> print vK ->d      < 5.019004
-# c        <@> print vK/FOLD ->d >=5.019004
+# c        <@> print vK/FOLD ->d
 # a           <0> pushmark s ->b
 # b           <$> const[PV "b-gt-a"] s ->c
 # d        <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
-# g        <@> print vK ->h      < 5.019004
-# g        <@> print vK/FOLD ->h >=5.019004
+# g        <@> print vK/FOLD ->h
 # e           <0> pushmark s ->f
 # f           <$> const[PV "a-le-b"] s ->g
 # h        <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
-# k        <@> print vK ->l      < 5.019004
-# k        <@> print vK/FOLD ->l >=5.019004
+# k        <@> print vK/FOLD ->l
 # i           <0> pushmark s ->j
 # j           <$> const[PV "b-ge-a"] s ->k
 # l        <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
-# o        <@> print vK ->p      < 5.019004
-# o        <@> print vK/FOLD ->p >=5.019004
+# o        <@> print vK/FOLD ->p
 # m           <0> pushmark s ->n
 # n           <$> const[PV "b-cmp-a"] s ->o
 # p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
-# q        <$> const[PVNV 0] s/SHORT ->r      < 5.017002
-# q        <$> const[PVNV 0] s/FOLD,SHORT ->r >=5.017002 < 5.019003
-# q        <$> const[SPECIAL sv_no] s/SHORT,FOLD ->r >=5.019003
+# q        <$> const[SPECIAL sv_no] s/SHORT,FOLD ->r
 EOT_EOT
 # r  <1> leavesub[1 ref] K/REFC,1 ->(end)
 # -     <@> lineseq KP ->r
 # 1        <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
 # 4        <2> sassign vKS/2 ->5
-# 2           <$> const(PV "FOO.Bar.low.lOW") s ->3      < 5.017002
-# 2           <$> const(PV "FOO.Bar.low.lOW") s/FOLD ->3 >=5.017002
+# 2           <$> const(PV "FOO.Bar.low.lOW") s/FOLD ->3
 # -           <1> ex-rv2sv sKRM*/1 ->4
 # 3              <$> gvsv(*s) s ->4
 # 5        <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
-# 8        <@> print vK ->9      < 5.019004
-# 8        <@> print vK/FOLD ->9 >=5.019004
+# 8        <@> print vK/FOLD ->9
 # 6           <0> pushmark s ->7
 # 7           <$> const(PV "a-lt-b") s ->8
 # 9        <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
-# c        <@> print vK ->d      < 5.019004
-# c        <@> print vK/FOLD ->d >=5.019004
+# c        <@> print vK/FOLD ->d
 # a           <0> pushmark s ->b
 # b           <$> const(PV "b-gt-a") s ->c
 # d        <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
-# g        <@> print vK ->h      < 5.019004
-# g        <@> print vK/FOLD ->h >=5.019004
+# g        <@> print vK/FOLD ->h
 # e           <0> pushmark s ->f
 # f           <$> const(PV "a-le-b") s ->g
 # h        <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
-# k        <@> print vK ->l      < 5.019004
-# k        <@> print vK/FOLD ->l >=5.019004
+# k        <@> print vK/FOLD ->l
 # i           <0> pushmark s ->j
 # j           <$> const(PV "b-ge-a") s ->k
 # l        <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
-# o        <@> print vK ->p      < 5.019004
-# o        <@> print vK/FOLD ->p >=5.019004
+# o        <@> print vK/FOLD ->p
 # m           <0> pushmark s ->n
 # n           <$> const(PV "b-cmp-a") s ->o
 # p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
-# q        <$> const(SPECIAL sv_no) s/SHORT ->r      < 5.017002
-# q        <$> const(SPECIAL sv_no) s/SHORT,FOLD ->r >=5.017002
+# q        <$> const(SPECIAL sv_no) s/SHORT,FOLD ->r
 EONT_EONT
 
 checkOptree ( name	=> 'mixed constant folding, with explicit braces',
@@ -409,16 +377,14 @@ checkOptree ( name	=> 'mixed constant folding, with explicit braces',
 # 1        <;> nextstate(main 977 (eval 28):1) v ->2
 # 4        <@> print sK ->5
 # 2           <0> pushmark s ->3
-# 3           <$> const[PV "foobar5"] s ->4      < 5.017002
-# 3           <$> const[PV "foobar5"] s/FOLD ->4 >=5.017002
+# 3           <$> const[PV "foobar5"] s/FOLD ->4
 EOT_EOT
 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 # -     <@> lineseq KP ->5
 # 1        <;> nextstate(main 977 (eval 28):1) v ->2
 # 4        <@> print sK ->5
 # 2           <0> pushmark s ->3
-# 3           <$> const(PV "foobar5") s ->4      < 5.017002
-# 3           <$> const(PV "foobar5") s/FOLD ->4 >=5.017002
+# 3           <$> const(PV "foobar5") s/FOLD ->4
 EONT_EONT
 
 __END__
diff --git a/gnu/usr.bin/perl/ext/B/t/strict.t b/gnu/usr.bin/perl/ext/B/t/strict.t
new file mode 100644
index 00000000000..4d1b84aa20d
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/B/t/strict.t
@@ -0,0 +1,30 @@
+#!./perl -w
+
+use strict;
+use warnings;
+
+use Config;
+use Test::More;
+
+BEGIN {
+    if ( ( $Config{'extensions'} !~ /\sB\s/ ) ) {
+        plan skip_all => "Perl was not compiled with B";
+        exit 0;
+    }
+}
+
+use strict;
+use warnings;
+
+use B ();
+use O ();
+
+foreach my $module (qw/B O/) {
+    my $path  = $INC{ $module . '.pm' };
+    my $check = "$^X -cw -Mstrict $path 2>&1";
+    my $got   = `$check`;
+    is( $got, "$path syntax OK\n", "$module.pm compiles without errors" )
+      or diag($got);
+}
+
+done_testing();
diff --git a/gnu/usr.bin/perl/ext/B/t/terse.t b/gnu/usr.bin/perl/ext/B/t/terse.t
index 26e2e760546..7d0253addc3 100644
--- a/gnu/usr.bin/perl/ext/B/t/terse.t
+++ b/gnu/usr.bin/perl/ext/B/t/terse.t
@@ -63,7 +63,7 @@ warn "# didn't find " . join(' ', keys %ops) if keys %ops;
 # add it to the regex above too. (PADOPs are currently only produced
 # under ithreads, though).
 #
-use vars qw( $a $b );
+our ( $a, $b );
 sub bar {
 	# OP SVOP COP IV here or in sub definition
 	my @bar = (1, 2, 3);
@@ -92,11 +92,7 @@ sub bar {
 # Schwern's example of finding an RV
 my $path = join " ", map { qq["-I$_"] } @INC;
 my $items = qx{$^X $path "-MO=Terse" -le "print \\42" 2>&1};
-if( $] >= 5.011 ) {
-    like( $items, qr/IV $hex \\42/, 'RV (but now stored in an IV)' );
-} else {
-    like( $items, qr/RV $hex \\42/, 'RV' );
-}
+like( $items, qr/IV $hex \\42/, 'RV (but now stored in an IV)' );
 
 package TieOut;
 
diff --git a/gnu/usr.bin/perl/ext/B/t/walkoptree.t b/gnu/usr.bin/perl/ext/B/t/walkoptree.t
index 3648835b7f6..1d42dd51404 100644
--- a/gnu/usr.bin/perl/ext/B/t/walkoptree.t
+++ b/gnu/usr.bin/perl/ext/B/t/walkoptree.t
@@ -36,13 +36,13 @@ my $victim = sub {
     $_[0] =~ s/(a)/ $1/;
     # PMOP_pmreplroot(cPMOPo) is NULL for this
     $_[0] =~ s/(b)//;
-    # This gives an OP_PUSHRE
+    # This gives an OP_SPLIT
     split /c/;
 };
 
 is (B::walkoptree_debug, 0, 'walkoptree_debug() is 0');
 B::walkoptree(B::svref_2object($victim)->ROOT, "pie");
-foreach (qw(substcont pushre split leavesub)) {
+foreach (qw(substcont split split leavesub)) {
     is ($seen{$_}, 1, "Our victim had a $_ OP");
 }
 is_deeply ([keys %debug], [], 'walkoptree_debug was not called');
@@ -52,7 +52,7 @@ is (B::walkoptree_debug, 1, 'walkoptree_debug() is 1');
 %seen = ();
 
 B::walkoptree(B::svref_2object($victim)->ROOT, "pie");
-foreach (qw(substcont pushre split leavesub)) {
+foreach (qw(substcont split split leavesub)) {
     is ($seen{$_}, 1, "Our victim had a $_ OP");
 }
 is_deeply (\%debug, \%seen, 'walkoptree_debug was called correctly');
diff --git a/gnu/usr.bin/perl/ext/B/t/xref.t b/gnu/usr.bin/perl/ext/B/t/xref.t
index 32a80e73d5a..3e201c12e17 100644
--- a/gnu/usr.bin/perl/ext/B/t/xref.t
+++ b/gnu/usr.bin/perl/ext/B/t/xref.t
@@ -32,7 +32,7 @@ open STDOUT, ">&SAVEOUT" or diag $!;
 # line 200
 my ($curfile, $cursub, $curpack) = ('') x 3;
 our %xreftable = ();
-open XREF, $file or die "# Can't open $file: $!\n";
+open XREF, '<', $file or die "# Can't open $file: $!\n";
 while (<XREF>) {
     print STDERR $_ if $ENV{PERL_DEBUG};
     chomp;
diff --git a/gnu/usr.bin/perl/ext/Fcntl/t/fcntl.t b/gnu/usr.bin/perl/ext/Fcntl/t/fcntl.t
index b689f781cc8..af649b52ce1 100644
--- a/gnu/usr.bin/perl/ext/Fcntl/t/fcntl.t
+++ b/gnu/usr.bin/perl/ext/Fcntl/t/fcntl.t
@@ -12,11 +12,13 @@ print "1..7\n";
 print "ok 1\n";
 
 if (sysopen(my $wo, "fcntl$$", O_WRONLY|O_CREAT)) {
+    binmode $wo;
     print "ok 2\n";
     if (syswrite($wo, "foo") == 3) {
 	print "ok 3\n";
 	close($wo);
 	if (sysopen(my $ro, "fcntl$$", O_RDONLY)) {
+            binmode $ro;
 	    print "ok 4\n";
 	    if (sysread($ro, my $read, 3)) {
 		print "ok 5\n";
diff --git a/gnu/usr.bin/perl/ext/Fcntl/t/syslfs.t b/gnu/usr.bin/perl/ext/Fcntl/t/syslfs.t
index 09dea10453a..7537d548760 100644
--- a/gnu/usr.bin/perl/ext/Fcntl/t/syslfs.t
+++ b/gnu/usr.bin/perl/ext/Fcntl/t/syslfs.t
@@ -72,6 +72,7 @@ if ($^O eq 'unicos') {
 
 sysopen(BIG, $big1, O_WRONLY|O_CREAT|O_TRUNC) or
     die "sysopen $big1 failed: $!";
+binmode BIG;
 sysseek(BIG, 1_000_000, SEEK_SET) or
     die "sysseek $big1 failed: $!";
 syswrite(BIG, "big") or
@@ -85,6 +86,7 @@ print "# s1 = @s1\n";
 
 sysopen(BIG, $big2, O_WRONLY|O_CREAT|O_TRUNC) or
     die "sysopen $big2 failed: $!";
+binmode BIG;
 sysseek(BIG, 2_000_000, SEEK_SET) or
     die "sysseek $big2 failed: $!";
 syswrite(BIG, "big") or
@@ -127,6 +129,7 @@ EOF
 
 sysopen(BIG, $big0, O_WRONLY|O_CREAT|O_TRUNC) or
     die "sysopen $big0 failed: $!";
+binmode BIG;
 my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET);
 unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) {
     $sysseek = 'undef' unless defined $sysseek;
@@ -192,7 +195,7 @@ is(-e $big0, 1);
 is(-f $big0, 1);
 
 sysopen(BIG, $big0, O_RDONLY) or die "sysopen failed: $!";
-
+binmode BIG;
 offset('sysseek(BIG, 4_500_000_000, SEEK_SET)', 4_500_000_000);
 
 offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000);
@@ -234,7 +237,7 @@ explain() unless Test::Builder->new()->is_passing();
 END {
     # unlink may fail if applied directly to a large file
     # be paranoid about leaving 5 gig files lying around
-    open(BIG, ">$big0"); # truncate
+    open(BIG, '>', $big0); # truncate
     close(BIG);
 }
 
diff --git a/gnu/usr.bin/perl/ext/File-Glob/t/basic.t b/gnu/usr.bin/perl/ext/File-Glob/t/basic.t
index 2e6a4748d4d..f0363cdcdb5 100755
--- a/gnu/usr.bin/perl/ext/File-Glob/t/basic.t
+++ b/gnu/usr.bin/perl/ext/File-Glob/t/basic.t
@@ -44,7 +44,7 @@ if (opendir(D, ".")) {
    @correct = grep { !/^\./ } sort readdir(D);
    closedir D;
 }
-my @a = File::Glob::glob("*", 0);
+my @a = do {no warnings 'deprecated'; File::Glob::glob("*", 0);};
 @a = sort @a;
 if (GLOB_ERROR) {
     fail(GLOB_ERROR);
@@ -192,7 +192,7 @@ if ($^O eq 'VMS') { # VMS is happily caseignorant
 }
 
 for (@f_names) {
-    open T, "> $_";
+    open T, '>', $_;
     close T;
 }
 
diff --git a/gnu/usr.bin/perl/ext/File-Glob/t/rt131211.t b/gnu/usr.bin/perl/ext/File-Glob/t/rt131211.t
new file mode 100644
index 00000000000..4ac0d8729dc
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/File-Glob/t/rt131211.t
@@ -0,0 +1,112 @@
+# tests for RT 131211
+#
+# non-matching glob("a*a*a*...") went exponential time on number of a*'s
+
+
+use strict;
+use warnings;
+use v5.16.0;
+use File::Temp 'tempdir';
+use File::Spec::Functions;
+use Test::More;
+use Time::HiRes qw(time);
+use Config;
+
+plan skip_all => 'This platform doesn\'t use File::Glob'
+                    if $Config{ccflags} =~ /\b{wb}-DPERL_EXTERNAL_GLOB\b{wb}/;
+plan tests => 13;
+
+my $path = tempdir uc cleanup => 1;
+my @files= (
+    "x".("a" x 50)."b", # 0
+    "abbbbbbbbbbbbc",   # 1
+    "abbbbbbbbbbbbd",   # 2
+    "aaabaaaabaaaabc",  # 3
+    "pq",               # 4
+    "r",                # 5
+    "rttiiiiiii",       # 6
+    "wewewewewewe",     # 7
+    "weeeweeeweee",     # 8
+    "weewweewweew",     # 9
+    "wewewewewewewewewewewewewewewewewq", # 10
+    "wtttttttetttttttwr", # 11
+);
+
+
+# VMS needs a real extension.
+map { $_ .= '.tmp' } @files if $^O eq 'VMS';
+
+foreach (@files) {
+    open(my $f, ">", catfile $path, $_);
+}
+
+my $elapsed_fail= 0;
+my $elapsed_match= 0;
+my @got_files;
+my @no_files;
+my $count = 0;
+
+while (++$count < 10) {
+    $elapsed_match -= time;
+    @got_files= glob catfile $path, "x".("a*" x $count) . "b";
+    $elapsed_match += time;
+
+    $elapsed_fail -= time;
+    @no_files= glob catfile $path, "x".("a*" x $count) . "c";
+    $elapsed_fail += time;
+    last if $elapsed_fail > ($elapsed_match < 0.2 ? 0.2 : $elapsed_match) * 100;
+}
+
+is $count,10,
+    "tried all the patterns without bailing out"
+    or diag("elapsed_match=$elapsed_match elapsed_fail=$elapsed_fail");
+
+SKIP: {
+    skip "unstable  or too small timing", 1 unless
+            $elapsed_match >= 0.001 && $elapsed_fail >= 0.001;
+    ok $elapsed_fail <= 10 * $elapsed_match,
+        "time to fail less than 10x the time to match"
+        or diag("elapsed_match=$elapsed_match elapsed_fail=$elapsed_fail");
+}
+
+is "@got_files", catfile($path, $files[0]),
+    "only got the expected file for xa*..b";
+is "@no_files", "", "shouldnt have files for xa*..c";
+
+
+@got_files= glob catfile $path, "a*b*b*b*bc";
+is "@got_files", catfile($path, $files[1]),
+    "only got the expected file for a*b*b*b*bc";
+
+@got_files= sort glob catfile $path, "a*b*b*bc";
+is "@got_files", catfile($path, $files[3])." ".catfile($path,$files[1]),
+    "got the expected two files for a*b*b*bc";
+
+@got_files= sort glob catfile $path, "p*";
+is "@got_files", catfile($path, $files[4]),
+    "p* matches pq";
+
+@got_files= sort glob catfile $path, "r*???????";
+is "@got_files", catfile($path, $files[6]),
+    "r*??????? works as expected";
+
+@got_files= sort glob catfile $path, "w*e*w??e";
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8)),
+    "w*e*w??e works as expected";
+
+@got_files= sort glob catfile $path, "w*e*we??";
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8,9,10)),
+    "w*e*we?? works as expected";
+
+@got_files= sort glob catfile $path, "w**e**w";
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (9)),
+    "w**e**w works as expected";
+
+@got_files= sort glob catfile $path, "*wee*";
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (8,9)),
+    "*wee* works as expected";
+
+@got_files= sort glob catfile $path, "we*";
+is "@got_files", join(" ", sort map { catfile($path, $files[$_]) } (7,8,9,10)),
+    "we* works as expected";
+
diff --git a/gnu/usr.bin/perl/ext/FileCache/lib/FileCache.pm b/gnu/usr.bin/perl/ext/FileCache/lib/FileCache.pm
index 149e88133ef..0834719d9b9 100644
--- a/gnu/usr.bin/perl/ext/FileCache/lib/FileCache.pm
+++ b/gnu/usr.bin/perl/ext/FileCache/lib/FileCache.pm
@@ -1,6 +1,6 @@
 package FileCache;
 
-our $VERSION = '1.09';
+our $VERSION = '1.10';
 
 =head1 NAME
 
@@ -91,8 +91,8 @@ no strict 'refs';
 # These are not C<my> for legacy reasons.
 # Previous versions requested the user set $cacheout_maxopen by hand.
 # Some authors fiddled with %saw to overcome the clobber on initial open.
-use vars qw(%saw $cacheout_maxopen);
-$cacheout_maxopen = 16;
+our %saw;
+our $cacheout_maxopen = 16;
 
 use parent 'Exporter';
 our @EXPORT = qw[cacheout cacheout_close];
diff --git a/gnu/usr.bin/perl/ext/FileCache/t/01open.t b/gnu/usr.bin/perl/ext/FileCache/t/01open.t
index 07e01bac86c..c01b25a424e 100755
--- a/gnu/usr.bin/perl/ext/FileCache/t/01open.t
+++ b/gnu/usr.bin/perl/ext/FileCache/t/01open.t
@@ -2,7 +2,7 @@
 
 use FileCache;
 
-use vars qw(@files);
+our @files;
 BEGIN { @files = qw(foo bar baz quux Foo_Bar) }
 END   { 1 while unlink @files }
 
diff --git a/gnu/usr.bin/perl/ext/FileCache/t/02maxopen.t b/gnu/usr.bin/perl/ext/FileCache/t/02maxopen.t
index c95ba73bcac..f3470c1086b 100755
--- a/gnu/usr.bin/perl/ext/FileCache/t/02maxopen.t
+++ b/gnu/usr.bin/perl/ext/FileCache/t/02maxopen.t
@@ -1,7 +1,7 @@
 #!./perl
 
 use FileCache maxopen => 2;
-use vars qw(@files);
+our @files;
 BEGIN { @files = qw(foo bar baz quux) }
 END { 1 while unlink @files }
 
@@ -19,7 +19,7 @@ use Test::More tests => 5;
     next unless fileno($path);
     print $path "$path 2\n";
     close($path);
-    open($path, $path);
+    open($path, '<', $path);
     <$path>;
     push @cat, <$path>;
     close($path);
diff --git a/gnu/usr.bin/perl/ext/FileCache/t/03append.t b/gnu/usr.bin/perl/ext/FileCache/t/03append.t
index f765d445ce5..3a826793577 100755
--- a/gnu/usr.bin/perl/ext/FileCache/t/03append.t
+++ b/gnu/usr.bin/perl/ext/FileCache/t/03append.t
@@ -1,7 +1,7 @@
 #!./perl
 
 use FileCache maxopen => 2;
-use vars qw(@files);
+our @files;
 BEGIN { @files = qw(foo bar baz quux Foo_Bar) }
 END   { 1 while unlink @files }
 
diff --git a/gnu/usr.bin/perl/ext/FileCache/t/06export.t b/gnu/usr.bin/perl/ext/FileCache/t/06export.t
index 0fafe3bcd6c..9a46e2bebb1 100755
--- a/gnu/usr.bin/perl/ext/FileCache/t/06export.t
+++ b/gnu/usr.bin/perl/ext/FileCache/t/06export.t
@@ -1,5 +1,5 @@
 #!./perl
-use vars qw(@funcs $i);
+our (@funcs, $i);
 
 BEGIN {
     # Functions exported by FileCache;
diff --git a/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.xs b/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.xs
index 33e08e20d13..7f910491166 100644
--- a/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.xs
+++ b/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.xs
@@ -23,8 +23,6 @@ typedef datum datum_key ;
 typedef datum datum_value ;
 typedef datum datum_key_copy;
 
-#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
-
 #if defined(GDBM_VERSION_MAJOR) && defined(GDBM_VERSION_MINOR) \
     && GDBM_VERSION_MAJOR > 1 || \
     (GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 9)
@@ -81,17 +79,28 @@ gdbm_TIEHASH(dbtype, name, read_write, mode)
 	char *		name
 	int		read_write
 	int		mode
+	PREINIT:
+	GDBM_FILE dbp;
 	CODE:
-	{
-	    GDBM_FILE  	dbp ;
-
-	    RETVAL = NULL ;
-	    if ((dbp =  gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode,
-	       	     	          (FATALFUNC) croak_string))) {
-	        RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type)) ;
-		RETVAL->dbp = dbp ;
-	    }
-	    
+	dbp = gdbm_open(name, 0, read_write, mode, (FATALFUNC)croak_string);
+	if (!dbp && gdbm_errno == GDBM_BLOCK_SIZE_ERROR) {
+	    /*
+	     * By specifying a block size of 0 above, we asked gdbm to
+	     * default to the filesystem's block size.	That's usually the
+	     * right size to choose.  But some versions of gdbm require
+	     * a power-of-two block size, and some unusual filesystems
+	     * or devices have a non-power-of-two size that cause this
+	     * defaulting to fail.  In that case, force an acceptable
+	     * block size.
+	     */
+	    dbp = gdbm_open(name, 4096, read_write, mode,
+		    (FATALFUNC)croak_string);
+	}
+	if (dbp) {
+	    RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type));
+	    RETVAL->dbp = dbp;
+	} else {
+	    RETVAL = NULL;
 	}
 	OUTPUT:
 	  RETVAL
diff --git a/gnu/usr.bin/perl/ext/GDBM_File/t/fatal.t b/gnu/usr.bin/perl/ext/GDBM_File/t/fatal.t
index b7045bad696..0e426d4dbcd 100644
--- a/gnu/usr.bin/perl/ext/GDBM_File/t/fatal.t
+++ b/gnu/usr.bin/perl/ext/GDBM_File/t/fatal.t
@@ -18,7 +18,7 @@ BEGIN {
 
 unlink <Op_dbmx*>;
 
-open my $fh, $^X or die "Can't open $^X: $!";
+open my $fh, '<', $^X or die "Can't open $^X: $!";
 my $fileno = fileno $fh;
 isnt($fileno, undef, "Can find next available file descriptor");
 close $fh or die $!;
diff --git a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/12_hashwarn.t b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/12_hashwarn.t
index 5841c800469..3fd6bfd2dd2 100755
--- a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/12_hashwarn.t
+++ b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/12_hashwarn.t
@@ -7,8 +7,7 @@ use strict;
 use warnings;
 use Hash::Util::FieldHash qw( :all);
 
-use vars qw{ @warnings };
-
+our @warnings;
 BEGIN {
     $SIG{'__WARN__'} = sub { push @warnings, @_ };
     $| = 1;
diff --git a/gnu/usr.bin/perl/ext/Hash-Util/t/builtin.t b/gnu/usr.bin/perl/ext/Hash-Util/t/builtin.t
new file mode 100644
index 00000000000..0705f842063
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Hash-Util/t/builtin.t
@@ -0,0 +1,40 @@
+#!/usr/bin/perl -Tw
+
+use strict;
+use Test::More;
+
+my @Exported_Funcs;
+BEGIN {
+    @Exported_Funcs = qw( bucket_ratio num_buckets used_buckets );
+    plan tests => 13 + @Exported_Funcs;
+    use_ok 'Hash::Util', @Exported_Funcs;
+}
+foreach my $func (@Exported_Funcs) {
+    can_ok __PACKAGE__, $func;
+}
+
+my %hash;
+
+is(bucket_ratio(%hash), 0, "Empty hash has no bucket_ratio");
+is(num_buckets(%hash), 8, "Empty hash should have eight buckets");
+is(used_buckets(%hash), 0, "Empty hash should have no used buckets");
+
+$hash{1}= 1;
+is(bucket_ratio(%hash), "1/8", "hash has expected bucket_ratio");
+is(num_buckets(%hash), 8, "hash should have eight buckets");
+is(used_buckets(%hash), 1, "hash should have one used buckets");
+
+$hash{$_}= $_ for 2..7;
+
+like(bucket_ratio(%hash), qr!/(?:8|16)!, "hash has expected number of buckets in bucket_ratio");
+my $num= num_buckets(%hash);
+ok(($num == 8 || $num == 16), "hash should have 8 or 16 buckets");
+cmp_ok(used_buckets(%hash), "<", 8, "hash should have one used buckets");
+
+$hash{8}= 8;
+like(bucket_ratio(%hash), qr!/(?:8|16)!, "hash has expected number of buckets in bucket_ratio");
+$num= num_buckets(%hash);
+ok(($num == 8 || $num == 16), "hash should have 8 or 16 buckets");
+cmp_ok(used_buckets(%hash), "<=", 8, "hash should have at most 8 used buckets");
+
+
diff --git a/gnu/usr.bin/perl/ext/I18N-Langinfo/t/Langinfo.t b/gnu/usr.bin/perl/ext/I18N-Langinfo/t/Langinfo.t
index deaaf2851e4..f0768fbaa42 100755
--- a/gnu/usr.bin/perl/ext/I18N-Langinfo/t/Langinfo.t
+++ b/gnu/usr.bin/perl/ext/I18N-Langinfo/t/Langinfo.t
@@ -2,15 +2,42 @@
 use strict;
 use Config;
 use Test::More;
+require "../../t/loc_tools.pl";
 
 plan skip_all => "I18N::Langinfo or POSIX unavailable" 
     if $Config{'extensions'} !~ m!\bI18N/Langinfo\b!;
 
-my @constants = qw(ABDAY_1 DAY_1 ABMON_1 MON_1 RADIXCHAR AM_STR THOUSEP D_T_FMT D_FMT T_FMT);
+my @times  = qw( MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7
+                 MON_8 MON_9 MON_10 MON_11 MON_12
+                 DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7);
+my @constants = qw(ABDAY_1 DAY_1 ABMON_1 RADIXCHAR AM_STR THOUSEP D_T_FMT
+                   D_FMT T_FMT);
+push @constants, @times;
 
-plan tests => 1 + 3 * @constants;
+my %want =
+    (
+        RADIXCHAR	=> ".",
+        THOUSEP	=> "",
+     );
+
+# Abbreviated and full are swapped in many locales in early netbsd
+if (   $Config{osname} !~ / netbsd /ix
+    || $Config{osvers} !~ / ^ [1-6] \. /x)
+{
+    $want{ABDAY_1} = "Sun";
+    $want{DAY_1}   = "Sunday";
+    $want{ABMON_1} = "Jan";
+    $want{MON_1}   = "January";
+}
+
+my @want = sort keys %want;
+
+plan tests => 1 + 3 * @constants + keys(@want) + 1 + 2;
+
+use_ok('I18N::Langinfo', 'langinfo', @constants, 'CRNCYSTR');
 
-use_ok('I18N::Langinfo', 'langinfo', @constants);
+use POSIX;
+setlocale(LC_ALL, "C");
 
 for my $constant (@constants) {
     SKIP: {
@@ -22,53 +49,103 @@ for my $constant (@constants) {
     }
 }
 
-exit(0);
-
-# Background: the langinfo() (in C known as nl_langinfo()) interface
-# is supposed to be a portable way to fetch various language/country
-# (locale) dependent constants like "the first day of the week" or
-# "the decimal separator".  Give a portable (numeric) constant,
-# get back a language-specific string.  That's a comforting fantasy.
-# Now tune in for blunt reality: vendors seem to have implemented for
-# those constants whatever they felt like implementing.  The UNIX
-# standard says that one should have the RADIXCHAR constant for the
-# decimal separator.  Not so for many Linux and BSD implementations.
-# One should have the CODESET constant for returning the current
-# codeset (say, ISO 8859-1).  Not so.  So let's give up any real
-# testing (leave the old testing code here for old times' sake,
-# though.) --jhi
-
-my %want =
-    (
-     ABDAY_1	=> "Sun",
-     DAY_1	=> "Sunday",
-     ABMON_1	=> "Jan",
-     MON_1	=> "January",
-     RADIXCHAR	=> ".",
-     AM_STR	=> qr{^(?:am|a\.m\.)$}i,
-     THOUSEP	=> "",
-     D_T_FMT	=> qr{^%a %b %[de] %H:%M:%S %Y$},
-     D_FMT	=> qr{^%m/%d/%y$},
-     T_FMT	=> qr{^%H:%M:%S$},
-     );
-
-    
-my @want = sort keys %want;
-
-print "1..", scalar @want, "\n";
-    
 for my $i (1..@want) {
     my $try = $want[$i-1];
     eval { I18N::Langinfo->import($try) };
-    unless ($@) {
-	my $got = langinfo(&$try);
-	if (ref $want{$try} && $got =~ $want{$try} || $got eq $want{$try}) {
-	    print qq[ok $i - $try is "$got"\n];
-	} else {
-	    print qq[not ok $i - $try is "$got" not "$want{$try}"\n];
-	}
-    } else {
-	print qq[ok $i - Skip: $try not defined\n];
+    SKIP: {
+        skip "$try not defined", 1, if $@;
+        no strict 'refs';
+        is (langinfo(&$try), $want{$try}, "$try => '$want{$try}'");
     }
 }
 
+my $comma_locale;
+for (find_locales( [ 'LC_NUMERIC' ] )) {
+    use POSIX;
+    use locale;
+    setlocale(LC_NUMERIC, $_) or next;
+    my $in = 4.2; # avoid any constant folding bugs
+    my $s = sprintf("%g", $in);
+    if ($s eq "4,2")  {
+        $comma_locale = $_;
+        last;
+    }
+}
+
+SKIP: {
+    skip "Couldn't find a locale with a comma decimal pt", 1
+                                                        unless $comma_locale;
+
+    no strict 'refs';
+    is (langinfo(&RADIXCHAR), ",",
+        "Returns ',' for decimal pt for locale '$comma_locale'");
+}
+
+SKIP: {
+
+    my $found_time = 0;
+    my $found_monetary = 0;
+    my @locales = find_locales( [ 'LC_TIME', 'LC_CTYPE', 'LC_MONETARY' ]);
+
+    while (defined (my $utf8_locale = find_utf8_ctype_locale(\@locales))) {
+        if (! $found_time) {
+            setlocale(&LC_TIME, $utf8_locale);
+            foreach my $time_item (@times) {
+                my $eval_string = "langinfo(&$time_item)";
+                my $time_name = eval $eval_string;
+                if ($@) {
+                    fail("'$eval_string' failed: $@");
+                    last SKIP;
+                }
+                if (! defined $time_name) {
+                    fail("'$eval_string' returned undef");
+                    last SKIP;
+                }
+                if ($time_name eq "") {
+                    fail("'$eval_string' returned an empty name");
+                    last SKIP;
+                }
+
+                if ($time_name =~ /\P{ASCII}/) {
+                    ok(utf8::is_utf8($time_name), "The name for '$time_item' in $utf8_locale is a UTF8 string");
+                    $found_time = 1;
+                    last;
+                }
+            }
+        }
+
+        if (! $found_monetary) {
+            setlocale(&LC_MONETARY, $utf8_locale);
+            my $eval_string = "langinfo(&CRNCYSTR)";
+            my $symbol = eval $eval_string;
+            if ($@) {
+                fail("'$eval_string' failed: $@");
+                last SKIP;
+            }
+            if (! defined $symbol) {
+                fail("'$eval_string' returned undef");
+                last SKIP;
+            }
+            if ($symbol =~ /\P{ASCII}/) {
+                ok(utf8::is_utf8($symbol), "The name for 'CRNCYSTR' in $utf8_locale is a UTF8 string");
+                $found_monetary = 1;
+            }
+        }
+
+        last if $found_monetary && $found_time;
+
+        # Remove this locale from the list, and loop to find another utf8
+        # locale
+        @locales = grep { $_ ne $utf8_locale } @locales;
+    }
+
+    if ($found_time + $found_monetary < 2) {
+        my $message = "";
+        $message .= "time name" unless $found_time;
+        if (! $found_monetary) {
+            $message .= " nor" if $message;
+            "monetary name";
+        }
+        skip("Couldn't find a locale with a non-ascii $message", 2 - $found_time - $found_monetary);
+    }
+}
diff --git a/gnu/usr.bin/perl/ext/IPC-Open3/t/fd.t b/gnu/usr.bin/perl/ext/IPC-Open3/t/fd.t
index 2a71b1387c2..adb1f5cd65e 100644
--- a/gnu/usr.bin/perl/ext/IPC-Open3/t/fd.t
+++ b/gnu/usr.bin/perl/ext/IPC-Open3/t/fd.t
@@ -36,7 +36,7 @@ plan 3;
 
   fresh_perl_like(<<"EOP",
 use IPC::Open3;
-open FOO, '$file' or die \$!;
+open FOO, '<', '$file' or die \$!;
 open3('<&' . fileno FOO, my \$out, undef, \$ENV{PERLEXE}, '-eprint scalar <STDIN>');
 print <\$out>;
 EOP
diff --git a/gnu/usr.bin/perl/ext/POSIX/t/sysconf.t b/gnu/usr.bin/perl/ext/POSIX/t/sysconf.t
index f23e0d3b3b9..29cf20f2102 100644
--- a/gnu/usr.bin/perl/ext/POSIX/t/sysconf.t
+++ b/gnu/usr.bin/perl/ext/POSIX/t/sysconf.t
@@ -110,7 +110,7 @@ SKIP: {
 
     -c $TTY
 	or skip("$TTY not a character file", $n);
-    open(TTY, $TTY)
+    open(TTY, '<', $TTY)
 	or skip("failed to open $TTY: $!", $n);
     -t TTY
 	or skip("TTY ($TTY) not a terminal file", $n);
diff --git a/gnu/usr.bin/perl/ext/POSIX/t/unimplemented.t b/gnu/usr.bin/perl/ext/POSIX/t/unimplemented.t
index 2d8f8198319..6ee85f683da 100644
--- a/gnu/usr.bin/perl/ext/POSIX/t/unimplemented.t
+++ b/gnu/usr.bin/perl/ext/POSIX/t/unimplemented.t
@@ -83,15 +83,17 @@ foreach ([atexit => 'C-specific: use END {} instead'],
 	 [strspn => 'C-specific, stopped'],
 	 [strtok => 'C-specific, stopped'],
 	 [tmpfile => \'IO::File::new_tmpfile'],
+	 [tmpnam => \'use File::Temp'],
 	 [ungetc => \'IO::Handle::ungetc'],
 	 [vfprintf => 'C-specific, stopped'],
 	 [vprintf => 'C-specific, stopped'],
 	 [vsprintf => 'C-specific, stopped'],
+	 [L_tmpnam => 'C-specific, stopped'],
 	) {
     my ($func, $action) = @$_;
     my $expect = ref $action
-	? qr/Use method $$action\(\) instead of POSIX::$func\(\) at \(eval/
-	: qr/Unimplemented: POSIX::$func\(\) is \Q$action\E at \(eval/;
+	? qr/Unimplemented: POSIX::$func\(\): .*$$action(?:\(\))? instead at \(eval/
+	: qr/Unimplemented: POSIX::$func\(\): \Q$action\E at \(eval/;
     is(eval "POSIX::$func(); 1", undef, "POSIX::$func fails as expected");
     like($@, $expect, "POSIX::$func gives expected error message");
 }
diff --git a/gnu/usr.bin/perl/ext/POSIX/t/usage.t b/gnu/usr.bin/perl/ext/POSIX/t/usage.t
index 24e6a7e9163..8aba55c9cb9 100644
--- a/gnu/usr.bin/perl/ext/POSIX/t/usage.t
+++ b/gnu/usr.bin/perl/ext/POSIX/t/usage.t
@@ -18,7 +18,7 @@ for my $list ([qw(errno fork getchar getegid geteuid getgid getgroups getlogin
 	      [qw(abs alarm assert chdir closedir cos exit exp fabs fstat getc
 		  getenv getgrgid getgrnam getpwnam getpwuid gmtime isatty
 		  localtime log opendir raise readdir remove rewind rewinddir
-		  rmdir sin sleep sqrt stat strerror system tolower toupper
+		  rmdir sin sleep sqrt stat strerror system
 		  umask unlink)],
 	      [qw(atan2 chmod creat kill link mkdir pow rename strstr waitpid)],
 	      [qw(chown fcntl utime)]) {
@@ -32,10 +32,10 @@ foreach my $func (sort @all) {
     my $arg_pat = join ', ', ('[a-z]+') x $valid{$func};
     my $expect = qr/\AUsage: POSIX::$func\($arg_pat\) at \(eval/;
     foreach my $try (@try) {
-	next if $valid{$func} == $try;
-	my $call = "POSIX::$func(" . join(', ', 1 .. $try) . ')';
-	is(eval "$call; 1", undef, "$call fails");
-	like($@, $expect, "POSIX::$func for $try arguments gives expected error")
+	    next if $valid{$func} == $try;
+	    my $call = "POSIX::$func(" . join(', ', 1 .. $try) . ')';
+	    is(eval "$call; 1", undef, "$call fails");
+	    like($@, $expect, "POSIX::$func for $try arguments gives expected error")
     }
 }
 
diff --git a/gnu/usr.bin/perl/ext/PerlIO-via/t/thread.t b/gnu/usr.bin/perl/ext/PerlIO-via/t/thread.t
new file mode 100644
index 00000000000..e4358f9c24b
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/PerlIO-via/t/thread.t
@@ -0,0 +1,73 @@
+#!perl
+BEGIN {
+    unless (find PerlIO::Layer 'perlio') {
+	print "1..0 # Skip: not perlio\n";
+	exit 0;
+    }
+    require Config;
+    unless ($Config::Config{'usethreads'}) {
+        print "1..0 # Skip -- need threads for this test\n";
+        exit 0;
+    }
+    if (($Config::Config{'extensions'} !~ m!\bPerlIO/via\b!) ){
+        print "1..0 # Skip -- Perl configured without PerlIO::via module\n";
+        exit 0;
+    }
+}
+
+use strict;
+use warnings;
+use threads;
+
+my $tmp = "via$$";
+
+END {
+    1 while unlink $tmp;
+}
+
+use Test::More tests => 2;
+
+our $push_count = 0;
+
+{
+    open my $fh, ">:via(Test1)", $tmp
+      or die "Cannot open $tmp: $!";
+    $fh->autoflush;
+
+    print $fh "AXAX";
+
+    # previously this would crash
+    threads->create(
+        sub {
+            print $fh "XZXZ";
+        })->join;
+
+    print $fh "BXBX";
+    close $fh;
+
+    open my $in, "<", $tmp;
+    my $line = <$in>;
+    close $in;
+
+    is($line, "AYAYYZYZBYBY", "check thread data delivered");
+
+    is($push_count, 1, "PUSHED not called for dup on thread creation");
+}
+
+package PerlIO::via::Test1;
+
+sub PUSHED {
+    my ($class) = @_;
+    ++$main::push_count;
+    bless {}, $class;
+}
+
+sub WRITE {
+    my ($self, $data, $fh) = @_;
+    $data =~ tr/X/Y/;
+    $fh->autoflush;
+    print $fh $data;
+    return length $data;
+}
+
+
diff --git a/gnu/usr.bin/perl/ext/PerlIO-via/t/via.t b/gnu/usr.bin/perl/ext/PerlIO-via/t/via.t
index 0619592606e..80577df140a 100755
--- a/gnu/usr.bin/perl/ext/PerlIO-via/t/via.t
+++ b/gnu/usr.bin/perl/ext/PerlIO-via/t/via.t
@@ -17,7 +17,7 @@ use warnings;
 
 my $tmp = "via$$";
 
-use Test::More tests => 18;
+use Test::More tests => 26;
 
 my $fh;
 my $a = join("", map { chr } 0..255) x 10;
@@ -44,7 +44,7 @@ is($a, $b, 'compare original data with filtered version');
     use warnings 'layer';
 
     # Find fd number we should be using
-    my $fd = open($fh,">$tmp") && fileno($fh);
+    my $fd = open($fh,'>',$tmp) && fileno($fh);
     print $fh "Hello\n";
     close($fh);
 
@@ -52,7 +52,7 @@ is($a, $b, 'compare original data with filtered version');
     like( $warnings, qr/^Cannot find package 'Unknown::Module'/,  'warn about unknown package' );
 
     # Now open normally again to see if we get right fileno
-    my $fd2 = open($fh,"<$tmp") && fileno($fh);
+    my $fd2 = open($fh,'<',$tmp) && fileno($fh);
     is($fd2,$fd,"Wrong fd number after failed open");
 
     my $data = <$fh>;
@@ -84,6 +84,60 @@ is( $obj, 'Foo', 'search for package Foo' );
 open $fh, '<:via(Bar)', "bar";
 is( $obj, 'PerlIO::via::Bar', 'search for package PerlIO::via::Bar' );
 
+{
+    # [perl #131221]
+    ok(open(my $fh1, ">", $tmp), "open $tmp");
+    ok(binmode($fh1, ":via(XXX)"), "binmode :via(XXX) onto it");
+    ok(open(my $fh2, ">&", $fh1), "dup it");
+    close $fh1;
+    close $fh2;
+
+    # make sure the old workaround still works
+    ok(open($fh1, ">", $tmp), "open $tmp");
+    ok(binmode($fh1, ":via(YYY)"), "binmode :via(YYY) onto it");
+    ok(open($fh2, ">&", $fh1), "dup it");
+    print $fh2 "XZXZ";
+    close $fh1;
+    close $fh2;
+
+    ok(open($fh1, "<", $tmp), "open $tmp for check");
+    { local $/; $b = <$fh1> }
+    close $fh1;
+    is($b, "XZXZ", "check result is from non-filtering class");
+
+    package PerlIO::via::XXX;
+
+    sub PUSHED {
+        my $class = shift;
+        bless {}, $class;
+    }
+
+    sub WRITE {
+        my ($self, $buffer, $handle) = @_;
+
+        print $handle $buffer;
+        return length($buffer);
+    }
+    package PerlIO::via::YYY;
+
+    sub PUSHED {
+        my $class = shift;
+        bless {}, $class;
+    }
+
+    sub WRITE {
+        my ($self, $buffer, $handle) = @_;
+
+        $buffer =~ tr/X/Y/;
+        print $handle $buffer;
+        return length($buffer);
+    }
+
+    sub GETARG {
+        "XXX";
+    }
+}
+
 END {
     1 while unlink $tmp;
 }
diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/anchorify.t b/gnu/usr.bin/perl/ext/Pod-Html/t/anchorify.t
index d7b180818ff..0677f9ed302 100644
--- a/gnu/usr.bin/perl/ext/Pod-Html/t/anchorify.t
+++ b/gnu/usr.bin/perl/ext/Pod-Html/t/anchorify.t
@@ -23,18 +23,18 @@ foreach $i (0..$#poddata) {
     $heads{anchorify($1)} = 1 if $poddata[$i] =~ /=head[1-6]\s+(.*)/;
 }
 my %expected = map { $_ => 1 } qw(
-    name
-    description
-    subroutine
-    error
-    method
-    has_a_wordspace
-    hastrailingwordspace
-    hasleadingwordspace
-    has_extra_internalwordspace
-    hasquotes
-    hasquestionmark
-    has_hyphen_and_space
+    NAME
+    DESCRIPTION
+    Subroutine
+    Error
+    Method
+    Has_A_Wordspace
+    HasTrailingWordspace
+    HasLeadingWordspace
+    Has_Extra_InternalWordspace
+    Has_Quotes
+    Has_QuestionMark
+    Has_Hyphen_And_Space
 );
 is_deeply(
     \%heads,
diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/feature.t b/gnu/usr.bin/perl/ext/Pod-Html/t/feature.t
index 94354c75f91..313928117fa 100644
--- a/gnu/usr.bin/perl/ext/Pod-Html/t/feature.t
+++ b/gnu/usr.bin/perl/ext/Pod-Html/t/feature.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w                                         # -*- perl -*-
 
 BEGIN {
-    require "t/pod2html-lib.pl";
+    require "./t/pod2html-lib.pl";
 }
 
 use strict;
diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/feature2.t b/gnu/usr.bin/perl/ext/Pod-Html/t/feature2.t
index 0cc00725051..dfafbe9e40d 100644
--- a/gnu/usr.bin/perl/ext/Pod-Html/t/feature2.t
+++ b/gnu/usr.bin/perl/ext/Pod-Html/t/feature2.t
@@ -2,7 +2,7 @@
 
 
 BEGIN {
-    require "t/pod2html-lib.pl";
+    require "./t/pod2html-lib.pl";
 }
 
 use strict;
diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir1.t b/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir1.t
index 6a0857bd2b9..22632a18ba5 100644
--- a/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir1.t
+++ b/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir1.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w                                         # -*- perl -*-
 
 BEGIN {
-    require "t/pod2html-lib.pl";
+    require "./t/pod2html-lib.pl";
 }
 
 END {
@@ -52,7 +52,7 @@ __DATA__
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
 <html xmlns="http://www.w3.org/1999/xhtml">
 <head>
-<title></title>
+<title>htmldir - Test --htmldir feature</title>
 <meta http-equiv="content-type" content="text/html; charset=utf-8" />
 <link rev="made" href="mailto:[PERLADMIN]" />
 </head>
diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir2.t b/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir2.t
index d9aab5efb79..36efdb7ad8a 100644
--- a/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir2.t
+++ b/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir2.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w                                         # -*- perl -*-
 
 BEGIN {
-    require "t/pod2html-lib.pl";
+    require "./t/pod2html-lib.pl";
 }
 
 use strict;
@@ -39,7 +39,7 @@ __DATA__
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
 <html xmlns="http://www.w3.org/1999/xhtml">
 <head>
-<title></title>
+<title>htmldir - Test --htmldir feature</title>
 <meta http-equiv="content-type" content="text/html; charset=utf-8" />
 <link rev="made" href="mailto:[PERLADMIN]" />
 </head>
diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir3.t b/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir3.t
index 8006bf017c2..3bcf4d09c96 100644
--- a/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir3.t
+++ b/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir3.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w                                         # -*- perl -*-
 
 BEGIN {
-    require "t/pod2html-lib.pl";
+    require "./t/pod2html-lib.pl";
 }
 
 END {
@@ -48,7 +48,7 @@ __DATA__
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
 <html xmlns="http://www.w3.org/1999/xhtml">
 <head>
-<title></title>
+<title>htmldir - Test --htmldir feature</title>
 <meta http-equiv="content-type" content="text/html; charset=utf-8" />
 <link rev="made" href="mailto:[PERLADMIN]" />
 </head>
diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir4.t b/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir4.t
index 31e7bdee70d..14435fa8d21 100644
--- a/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir4.t
+++ b/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir4.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w                                         # -*- perl -*-
 
 BEGIN {
-    require "t/pod2html-lib.pl";
+    require "./t/pod2html-lib.pl";
 }
 
 use strict;
@@ -34,7 +34,7 @@ __DATA__
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
 <html xmlns="http://www.w3.org/1999/xhtml">
 <head>
-<title></title>
+<title>htmldir - Test --htmldir feature</title>
 <meta http-equiv="content-type" content="text/html; charset=utf-8" />
 <link rev="made" href="mailto:[PERLADMIN]" />
 </head>
diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir5.t b/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir5.t
index 820590f2da1..3f53d3ffba1 100644
--- a/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir5.t
+++ b/gnu/usr.bin/perl/ext/Pod-Html/t/htmldir5.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w                                         # -*- perl -*-
 
 BEGIN {
-    require "t/pod2html-lib.pl";
+    require "./t/pod2html-lib.pl";
 }
 
 END {
@@ -37,7 +37,7 @@ __DATA__
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
 <html xmlns="http://www.w3.org/1999/xhtml">
 <head>
-<title></title>
+<title>htmldir - Test --htmldir feature</title>
 <meta http-equiv="content-type" content="text/html; charset=utf-8" />
 <link rev="made" href="mailto:[PERLADMIN]" />
 </head>
diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/htmlescp.t b/gnu/usr.bin/perl/ext/Pod-Html/t/htmlescp.t
index bb85e839350..fd5207ab223 100644
--- a/gnu/usr.bin/perl/ext/Pod-Html/t/htmlescp.t
+++ b/gnu/usr.bin/perl/ext/Pod-Html/t/htmlescp.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w                                         # -*- perl -*-
 
 BEGIN {
-    require "t/pod2html-lib.pl";
+    require "./t/pod2html-lib.pl";
 }
 
 use strict;
@@ -14,7 +14,7 @@ __DATA__
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
 <html xmlns="http://www.w3.org/1999/xhtml">
 <head>
-<title></title>
+<title>Escape Sequences Test</title>
 <meta http-equiv="content-type" content="text/html; charset=utf-8" />
 <link rev="made" href="mailto:[PERLADMIN]" />
 </head>
diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/htmllink.t b/gnu/usr.bin/perl/ext/Pod-Html/t/htmllink.t
index b13bf0cdf87..033c93f16f9 100644
--- a/gnu/usr.bin/perl/ext/Pod-Html/t/htmllink.t
+++ b/gnu/usr.bin/perl/ext/Pod-Html/t/htmllink.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w                                         # -*- perl -*-
 
 BEGIN {
-    require "t/pod2html-lib.pl";
+    require "./t/pod2html-lib.pl";
 }
 
 use strict;
@@ -14,7 +14,7 @@ __DATA__
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
 <html xmlns="http://www.w3.org/1999/xhtml">
 <head>
-<title></title>
+<title>htmllink - Test HTML links</title>
 <meta http-equiv="content-type" content="text/html; charset=utf-8" />
 <link rev="made" href="mailto:[PERLADMIN]" />
 </head>
diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/poderr.t b/gnu/usr.bin/perl/ext/Pod-Html/t/poderr.t
index f83057eceb8..ae1a751f951 100644
--- a/gnu/usr.bin/perl/ext/Pod-Html/t/poderr.t
+++ b/gnu/usr.bin/perl/ext/Pod-Html/t/poderr.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w                                         # -*- perl -*-
 
 BEGIN {
-    require "t/pod2html-lib.pl";
+    require "./t/pod2html-lib.pl";
 }
 
 use strict;
diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/podnoerr.t b/gnu/usr.bin/perl/ext/Pod-Html/t/podnoerr.t
index b49a3ac1cf3..3679a7b1fdb 100644
--- a/gnu/usr.bin/perl/ext/Pod-Html/t/podnoerr.t
+++ b/gnu/usr.bin/perl/ext/Pod-Html/t/podnoerr.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w                                         # -*- perl -*-
 
 BEGIN {
-    require "t/pod2html-lib.pl";
+    require "./t/pod2html-lib.pl";
 }
 
 use strict;
diff --git a/gnu/usr.bin/perl/ext/Sys-Hostname/t/Hostname.t b/gnu/usr.bin/perl/ext/Sys-Hostname/t/Hostname.t
index 40352ba2377..a8c259d7c90 100755
--- a/gnu/usr.bin/perl/ext/Sys-Hostname/t/Hostname.t
+++ b/gnu/usr.bin/perl/ext/Sys-Hostname/t/Hostname.t
@@ -10,14 +10,28 @@ BEGIN {
 
 use Sys::Hostname;
 
-eval {
-    $host = hostname;
-};
+use Test::More tests => 4;
 
-if ($@) {
-    print "1..0\n" if $@ =~ /Cannot get host name/;
-} else {
-    print "1..1\n";
-    print "# \$host = '$host'\n";
-    print "ok 1\n";
+SKIP:
+{
+    eval {
+        $host = hostname;
+    };
+    skip "No hostname available", 1
+      if $@ =~ /Cannot get host name/;
+    isnt($host, undef, "got a hostname");
+}
+
+{
+    use warnings;
+    my $warn;
+    local $SIG{__WARN__} = sub { $warn = "@_" };
+    eval { hostname("dummy") };
+    ok($warn, "warns with an argument");
+    like($warn, qr/hostname\(\) doesn't accept any arguments/,
+         "appropriate message");
+    no warnings "deprecated";
+    undef $warn;
+    eval { hostname("dummy") };
+    is($warn, undef, "no warning when disabled");
 }
diff --git a/gnu/usr.bin/perl/ext/Tie-Hash-NamedCapture/NamedCapture.pm b/gnu/usr.bin/perl/ext/Tie-Hash-NamedCapture/NamedCapture.pm
index 9702666799c..32a0029ceed 100644
--- a/gnu/usr.bin/perl/ext/Tie-Hash-NamedCapture/NamedCapture.pm
+++ b/gnu/usr.bin/perl/ext/Tie-Hash-NamedCapture/NamedCapture.pm
@@ -1,7 +1,7 @@
 use strict;
 package Tie::Hash::NamedCapture;
 
-our $VERSION = "0.09";
+our $VERSION = "0.10";
 
 require XSLoader;
 XSLoader::load(); # This returns true, which makes require happy.
diff --git a/gnu/usr.bin/perl/ext/Tie-Hash-NamedCapture/NamedCapture.xs b/gnu/usr.bin/perl/ext/Tie-Hash-NamedCapture/NamedCapture.xs
index 04cc4638e64..7eaae5614d0 100644
--- a/gnu/usr.bin/perl/ext/Tie-Hash-NamedCapture/NamedCapture.xs
+++ b/gnu/usr.bin/perl/ext/Tie-Hash-NamedCapture/NamedCapture.xs
@@ -16,31 +16,23 @@
 #define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
 #define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
 
-static void
-tie_it(pTHX_ const char name, UV flag, HV *const stash)
-{
-    GV *const gv = gv_fetchpvn(&name, 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PVHV);
-    HV *const hv = GvHV(gv);
-    SV *rv = newSV_type(SVt_RV);
+MODULE = Tie::Hash::NamedCapture	PACKAGE = Tie::Hash::NamedCapture
+PROTOTYPES: DISABLE
 
-    SvRV_set(rv, newSVuv(flag));
+void
+_tie_it(SV *sv)
+  INIT:
+    GV * const gv = (GV *)sv;
+    HV * const hv = GvHVn(gv);
+    SV *rv = newSV_type(SVt_RV);
+  CODE:
+    SvRV_set(rv, newSVuv(*GvNAME(gv) == '-' ? RXapif_ALL : RXapif_ONE));
     SvROK_on(rv);
-    sv_bless(rv, stash);
+    sv_bless(rv, GvSTASH(CvGV(cv)));
 
     sv_unmagic((SV *)hv, PERL_MAGIC_tied);
     sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
     SvREFCNT_dec(rv); /* As sv_magic increased it by one.  */
-}
-
-MODULE = Tie::Hash::NamedCapture	PACKAGE = Tie::Hash::NamedCapture
-PROTOTYPES: DISABLE
-
-BOOT:
-	{
-	    HV *const stash = GvSTASH(CvGV(cv));
-	    tie_it(aTHX_ '-', RXapif_ALL, stash);
-	    tie_it(aTHX_ '+', RXapif_ONE, stash);
-	}
 
 SV *
 TIEHASH(package, ...)
diff --git a/gnu/usr.bin/perl/ext/VMS-Stdio/Stdio.pm b/gnu/usr.bin/perl/ext/VMS-Stdio/Stdio.pm
index 4d05994279e..02ba8668ed4 100644
--- a/gnu/usr.bin/perl/ext/VMS-Stdio/Stdio.pm
+++ b/gnu/usr.bin/perl/ext/VMS-Stdio/Stdio.pm
@@ -8,18 +8,17 @@
 package VMS::Stdio;
 
 require 5.002;
-use vars qw( $VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS @ISA );
 use Carp '&croak';
 use DynaLoader ();
 use Exporter ();
- 
-$VERSION = '2.41';
-@ISA = qw( Exporter DynaLoader IO::File );
-@EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL  &O_NDELAY &O_NOWAIT
+
+our $VERSION = '2.44';
+our @ISA = qw( Exporter DynaLoader IO::File );
+our @EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL  &O_NDELAY &O_NOWAIT
               &O_RDONLY &O_RDWR  &O_TRUNC &O_WRONLY );
-@EXPORT_OK = qw( &binmode &flush &getname &remove &rewind &sync &setdef &tmpnam
+our @EXPORT_OK = qw( &binmode &flush &getname &remove &rewind &sync &setdef &tmpnam
                  &vmsopen &vmssysopen &waitfh &writeof );
-%EXPORT_TAGS = ( CONSTANTS => [ qw( &O_APPEND &O_CREAT &O_EXCL  &O_NDELAY
+our %EXPORT_TAGS = ( CONSTANTS => [ qw( &O_APPEND &O_CREAT &O_EXCL  &O_NDELAY
                                     &O_NOWAIT &O_RDONLY &O_RDWR &O_TRUNC
                                     &O_WRONLY ) ],
                  FUNCTIONS => [ qw( &binmode &flush &getname &remove &rewind
@@ -48,30 +47,6 @@ sub AUTOLOAD {
 sub DESTROY { close($_[0]); }
 
 
-################################################################################
-# Intercept calls to old VMS::stdio package, complain, and hand off
-# This will be removed in a future version of VMS::Stdio
-
-package VMS::stdio;
-
-sub AUTOLOAD {
-  my($func) = $AUTOLOAD;
-  $func =~ s/.*:://;
-  # Cheap trick: we know DynaLoader has required Carp.pm
-  Carp::carp("Old package VMS::stdio is now VMS::Stdio; please update your code");
-  if ($func eq 'vmsfopen') {
-    Carp::carp("Old function &vmsfopen is now &vmsopen");
-    goto &VMS::Stdio::vmsopen;
-  }
-  elsif ($func eq 'fgetname') {
-    Carp::carp("Old function &fgetname is now &getname");
-    goto &VMS::Stdio::getname;
-  }
-  else { goto &{"VMS::Stdio::$func"}; }
-}
-
-package VMS::Stdio;  # in case we ever use AutoLoader
-
 1;
 
 __END__
@@ -138,13 +113,11 @@ is done to save startup time for users who don't wish to use
 the IO::File methods.
 
 B<Note:>  In order to conform to naming conventions for Perl
-extensions and functions, the name of this package has been
-changed to VMS::Stdio as of Perl 5.002, and the names of some
-routines have been changed.  Calls to the old VMS::stdio routines
-will generate a warning, and will be routed to the equivalent
-VMS::Stdio function.  This compatibility interface will be
-removed in a future release of this extension, so please
-update your code to use the new routines.
+extensions and functions, the name of this package was
+changed to from VMS::stdio to VMS::Stdio as of Perl 5.002, and the names of some
+routines were changed.  For many releases, calls to the old VMS::stdio routines
+would generate a warning, and then route to the equivalent
+VMS::Stdio function.  This compatibility interface has now been removed.
 
 =over 4
 
diff --git a/gnu/usr.bin/perl/ext/VMS-Stdio/Stdio.xs b/gnu/usr.bin/perl/ext/VMS-Stdio/Stdio.xs
index 144f9370cc7..64e1ef344b1 100644
--- a/gnu/usr.bin/perl/ext/VMS-Stdio/Stdio.xs
+++ b/gnu/usr.bin/perl/ext/VMS-Stdio/Stdio.xs
@@ -4,6 +4,9 @@
  *
  */
 
+/* We now depend on handy.h macros that are not public API. */
+#define PERL_EXT
+
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
@@ -15,7 +18,7 @@
 static bool
 constant(char *name, IV *pval)
 {
-    if (strnNE(name, "O_", 2)) return FALSE;
+    if (! strBEGINs(name, "O_")) return FALSE;
 
     if (strEQ(name, "O_APPEND"))
 #ifdef O_APPEND
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/APItest_BS b/gnu/usr.bin/perl/ext/XS-APItest/APItest_BS
new file mode 100644
index 00000000000..d9ec22fb628
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/APItest_BS
@@ -0,0 +1,7 @@
+#
+# test that non-empty .bs files get executed (but only once)
+
+$bscode = <<'EOF';
+$::bs_file_got_executed++;
+EOF
+
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/autoload.t b/gnu/usr.bin/perl/ext/XS-APItest/t/autoload.t
index bb670e91b6a..b3599b362c3 100644
--- a/gnu/usr.bin/perl/ext/XS-APItest/t/autoload.t
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/autoload.t
@@ -80,12 +80,12 @@ is join(" ", eval 'a "b", "c"'), '$',
 ok(XS::APItest::AUTOLOADtest->can('AUTOLOAD'), 'Test class ->can AUTOLOAD');
 
 # Used to communicate from the XS AUTOLOAD to Perl land
-use vars '$the_method';
+our $the_method;
 
 # First, set up the Perl equivalent to what we're testing in
 # XS so we have a comparison
 package PerlBase;
-use vars '$AUTOLOAD';
+our $AUTOLOAD;
 sub AUTOLOAD {
   Test::More::ok(defined $AUTOLOAD);
   return 1 if not defined $AUTOLOAD;
@@ -94,12 +94,10 @@ sub AUTOLOAD {
 }
 
 package PerlDerived;
-use vars '@ISA';
-@ISA = qw(PerlBase);
+our @ISA = qw(PerlBase);
 
 package Derived;
-use vars '@ISA';
-@ISA = qw(XS::APItest::AUTOLOADtest);
+our @ISA = qw(XS::APItest::AUTOLOADtest);
 
 package main;
 
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/blockhooks.t b/gnu/usr.bin/perl/ext/XS-APItest/t/blockhooks.t
index 37590bc7ab9..a2a5486aed9 100644
--- a/gnu/usr.bin/perl/ext/XS-APItest/t/blockhooks.t
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/blockhooks.t
@@ -5,6 +5,9 @@ use strict;
 use Test::More tests => 17;
 
 use XS::APItest;
+
+BEGIN { push @INC, '.' } # t/BHK.pm is in ext/XS-APItest/ directory
+
 use t::BHK ();      # make sure it gets compiled early
 
 BEGIN { package XS::APItest; *main::bhkav = \@XS::APItest::bhkav }
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/bootstrap.t b/gnu/usr.bin/perl/ext/XS-APItest/t/bootstrap.t
new file mode 100644
index 00000000000..2c6c03466fa
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/bootstrap.t
@@ -0,0 +1,17 @@
+#!perl -w
+#
+# check that .bs files are loaded and executed.
+# During build of  XS::APItest, the presence of APItest_BS should
+# cause a non-empty APItest.bs file to auto-generated. When loading
+# APItest.so, the .bs should be automatically executed, which should
+# set $::bs_file_got_executed.
+
+use strict;
+
+use Test::More;
+use XS::APItest;
+
+is $::bs_file_got_executed, 1, "BS file was executed once";
+
+done_testing();
+
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/get.t b/gnu/usr.bin/perl/ext/XS-APItest/t/get.t
new file mode 100644
index 00000000000..2264d664f9d
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/get.t
@@ -0,0 +1,22 @@
+
+# Tests for the get_*v functions.
+
+use Test::More tests => 5;
+use XS::APItest;
+
+# XXX So far we only test get_cv.
+
+is get_cv("utf8::encode"), \&utf8::encode, 'get_cv(utf8::encode)';
+
+sub foo { " ooof" } # should be stored in the stash as a subref
+die "Test has been sabotaged: sub foo{} should not create a full glob"
+    unless ref $::{foo} eq 'CODE';
+
+my $subref = get_cv("foo");
+is ref $subref, "CODE", 'got a coderef from get_cv("globless sub")';
+is &$subref, " ooof", 'got the right sub';
+
+sub bar { "burr" }
+$subref = get_cv_flags("bar",GV_NOADD_NOINIT);
+is ref $subref, "CODE", 'got a coderef from get_cv with GV_NOADD_NOINIT';
+is &$subref, "burr", 'got the right sub';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/gv_fetchmeth.t b/gnu/usr.bin/perl/ext/XS-APItest/t/gv_fetchmeth.t
index 9f6e884a112..9ba1650e8f3 100644
--- a/gnu/usr.bin/perl/ext/XS-APItest/t/gv_fetchmeth.t
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/gv_fetchmeth.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 40;
+use Test::More tests => 44;
 
 use_ok('XS::APItest');
 
@@ -45,6 +45,10 @@ ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 3, $level, 0), "g
 
     sub ｍｅｔｈｏｄ { 1 }
 
+    use constant { φου1 => 1,
+                   φου2 => 2,
+                   φου3 => 3, };
+
     my $meth_as_octets =
             "\357\275\215\357\275\205\357\275\224\357\275\210\357\275\217\357\275\204";
 
@@ -53,6 +57,7 @@ ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 3, $level, 0), "g
         ::is XS::APItest::gv_fetchmeth_type(\%ｍａｉｎ::, "ｍｅｔｈｏｄ", $type, $level, 0), "*ｍａｉｎ::ｍｅｔｈｏｄ", "$types[$type] is UTF-8 clean";
         ::ok !XS::APItest::gv_fetchmeth_type(\%ｍａｉｎ::, $meth_as_octets, $type, $level, 0);
         ::ok !XS::APItest::gv_fetchmeth_type(\%ｍａｉｎ::, "method", $type, $level, 0);
+        ::is XS::APItest::gv_fetchmeth_type(\%ｍａｉｎ::, "φου$type", $type, $level, 0), "*ｍａｉｎ::φου$type", "$types[$type] can fetch UTF-8 constant";
         
         {
             no strict 'refs';
@@ -65,3 +70,10 @@ ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 3, $level, 0), "g
         }
     }
 }
+
+{
+    @Foo::ISA = qw/Bar/;
+    @Bar::ISA = qw//;
+
+    is(XS::APItest::gv_fetchmeth_type(\%Foo::, "nomethod", 1, -1, 0), undef, 'gv_fetchmeth_sv survives @ISA traversal');
+}
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/gv_fetchmethod_flags.t b/gnu/usr.bin/perl/ext/XS-APItest/t/gv_fetchmethod_flags.t
index 15d1c41c6ab..2da3b70685b 100644
--- a/gnu/usr.bin/perl/ext/XS-APItest/t/gv_fetchmethod_flags.t
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/gv_fetchmethod_flags.t
@@ -49,3 +49,8 @@ is XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 2, 0), "*m
         }
     }
 }
+
+# [perl #129267] Buffer overrun when argument name ends with colon and
+#                there is a colon past the end.  This used to segv.
+XS::APItest::gv_fetchmethod_flags_type(\%::, "method:::::", 4, 7);
+                                             # With type 4, 7 is the length
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy00.t b/gnu/usr.bin/perl/ext/XS-APItest/t/handy00.t
new file mode 100644
index 00000000000..7c3e4e3e729
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/handy00.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 0;
+
+do './t/handy_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy01.t b/gnu/usr.bin/perl/ext/XS-APItest/t/handy01.t
new file mode 100644
index 00000000000..2fd8ec1d21b
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/handy01.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 1;
+
+do './t/handy_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy02.t b/gnu/usr.bin/perl/ext/XS-APItest/t/handy02.t
new file mode 100644
index 00000000000..2d4e78d311b
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/handy02.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 2;
+
+do './t/handy_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy03.t b/gnu/usr.bin/perl/ext/XS-APItest/t/handy03.t
new file mode 100644
index 00000000000..fe07af3b64b
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/handy03.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 3;
+
+do './t/handy_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy04.t b/gnu/usr.bin/perl/ext/XS-APItest/t/handy04.t
new file mode 100644
index 00000000000..08977a1aa73
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/handy04.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 4;
+
+do './t/handy_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy05.t b/gnu/usr.bin/perl/ext/XS-APItest/t/handy05.t
new file mode 100644
index 00000000000..d2bb9269bc7
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/handy05.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 5;
+
+do './t/handy_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy06.t b/gnu/usr.bin/perl/ext/XS-APItest/t/handy06.t
new file mode 100644
index 00000000000..44fd1c63467
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/handy06.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 6;
+
+do './t/handy_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy07.t b/gnu/usr.bin/perl/ext/XS-APItest/t/handy07.t
new file mode 100644
index 00000000000..c6c2d5092a4
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/handy07.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 7;
+
+do './t/handy_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy08.t b/gnu/usr.bin/perl/ext/XS-APItest/t/handy08.t
new file mode 100644
index 00000000000..7e546d73713
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/handy08.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 8;
+
+do './t/handy_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy09.t b/gnu/usr.bin/perl/ext/XS-APItest/t/handy09.t
new file mode 100644
index 00000000000..38d89c0c735
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/handy09.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 9;
+
+do './t/handy_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy_base.pl b/gnu/usr.bin/perl/ext/XS-APItest/t/handy_base.pl
new file mode 100644
index 00000000000..7e8194e6433
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/handy_base.pl
@@ -0,0 +1,624 @@
+#!perl -w
+
+BEGIN {
+    require 'loc_tools.pl';   # Contains locales_enabled() and
+                              # find_utf8_ctype_locale()
+}
+
+use strict;
+use Test::More;
+use Config;
+
+use XS::APItest;
+
+my $tab = " " x 4;  # Indent subsidiary tests this much
+
+use Unicode::UCD qw(search_invlist prop_invmap prop_invlist);
+my ($charname_list, $charname_map, $format, $default) = prop_invmap("Name Alias");
+
+sub get_charname($) {
+    my $cp = shift;
+
+    # If there is a an abbreviation for the code point name, use it
+    my $name_index = search_invlist(\@{$charname_list}, $cp);
+    if (defined $name_index) {
+        my $synonyms = $charname_map->[$name_index];
+        if (ref $synonyms) {
+            my $pat = qr/: abbreviation/;
+            my @abbreviations = grep { $_ =~ $pat } @$synonyms;
+            if (@abbreviations) {
+                return $abbreviations[0] =~ s/$pat//r;
+            }
+        }
+    }
+
+    # Otherwise, use the full name
+    use charnames ();
+    return charnames::viacode($cp) // "No name";
+}
+
+sub truth($) {  # Converts values so is() works
+    return (shift) ? 1 : 0;
+}
+
+my $base_locale;
+my $utf8_locale;
+if(locales_enabled('LC_ALL')) {
+    require POSIX;
+    $base_locale = POSIX::setlocale( &POSIX::LC_ALL, "C");
+    if (defined $base_locale && $base_locale eq 'C') {
+        use locale; # make \w work right in non-ASCII lands
+
+        # Some locale implementations don't have the 128-255 characters all
+        # mean nothing.  Skip the locale tests in that situation
+        for my $u (128 .. 255) {
+            if (chr(utf8::unicode_to_native($u)) =~ /[[:print:]]/) {
+                undef $base_locale;
+                last;
+            }
+        }
+
+        $utf8_locale = find_utf8_ctype_locale() if $base_locale;
+    }
+}
+
+sub get_display_locale_or_skip($$) {
+
+    # Helper function intimately tied to its callers.  It knows the loop
+    # iterates with a locale of "", meaning don't use locale; $base_locale
+    # meaning to use a non-UTF-8 locale; and $utf8_locale.
+    #
+    # It checks to see if the current test should be skipped or executed,
+    # returning an empty list for the former, and for the latter:
+    #   ( 'locale display name',
+    #     bool of is this a UTF-8 locale )
+    #
+    # The display name is the empty string if not using locale.  Functions
+    # with _LC in their name are skipped unless in locale, and functions
+    # without _LC are executed only outside locale.
+
+    my ($locale, $suffix) = @_;
+
+    # The test should be skipped if the input is for a non-existent locale
+    return unless defined $locale;
+
+    # Here the input is defined, either a locale name or "".  If the test is
+    # for not using locales, we want to do the test for non-LC functions,
+    # and skip it for LC ones.
+    if ($locale eq "") {
+        return ("", 0) if $suffix !~ /LC/;
+        return;
+    }
+
+    # Here the input is for a real locale.  We don't test the non-LC functions
+    # for locales.
+    return if $suffix !~ /LC/;
+
+    # Here is for a LC function and a real locale.  The base locale is not
+    # UTF-8.
+    return (" ($locale locale)", 0) if $locale eq $base_locale;
+
+    # The only other possibility is that we have a UTF-8 locale
+    return (" ($locale)", 1);
+}
+
+sub try_malforming($$$)
+{
+    # Determines if the tests for malformed UTF-8 should be done.  When done,
+    # the .xs code creates malformations by pretending the length is shorter
+    # than it actually is.  Some things can't be malformed, and sometimes this
+    # test knows that the current code doesn't look for a malformation under
+    # various circumstances.
+
+    my ($u, $function, $using_locale) = @_;
+    # $u is unicode code point;
+
+    # Single bytes can't be malformed
+    return 0 if $u < ((ord "A" == 65) ? 128 : 160);
+
+    # ASCII doesn't need to ever look beyond the first byte.
+    return 0 if $function eq "ASCII";
+
+    # Nor, on EBCDIC systems, does CNTRL
+    return 0 if ord "A" != 65 && $function eq "CNTRL";
+
+    # No controls above 255, so the code doesn't look at those
+    return 0 if $u > 255 && $function eq "CNTRL";
+
+    # No non-ASCII digits below 256, except if using locales.
+    return 0 if $u < 256 && ! $using_locale && $function =~ /X?DIGIT/;
+
+    return 1;
+}
+
+my %properties = (
+                   # name => Lookup-property name
+                   alnum => 'Word',
+                   wordchar => 'Word',
+                   alphanumeric => 'Alnum',
+                   alpha => 'XPosixAlpha',
+                   ascii => 'ASCII',
+                   blank => 'Blank',
+                   cntrl => 'Control',
+                   digit => 'Digit',
+                   graph => 'Graph',
+                   idfirst => '_Perl_IDStart',
+                   idcont => '_Perl_IDCont',
+                   lower => 'XPosixLower',
+                   print => 'Print',
+                   psxspc => 'XPosixSpace',
+                   punct => 'XPosixPunct',
+                   quotemeta => '_Perl_Quotemeta',
+                   space => 'XPerlSpace',
+                   vertws => 'VertSpace',
+                   upper => 'XPosixUpper',
+                   xdigit => 'XDigit',
+                );
+
+my %seen;
+my @warnings;
+local $SIG{__WARN__} = sub { push @warnings, @_ };
+
+my %utf8_param_code = (
+                        "_safe"                 =>  0,
+                        "_safe, malformed"      =>  1,
+                        "deprecated unsafe"     => -1,
+                        "deprecated mathoms"    => -2,
+                      );
+
+# This test is split into this number of files.
+my $num_test_files = $ENV{TEST_JOBS} || 1;
+$::TEST_CHUNK = 0 if $num_test_files == 1 && ! defined $::TEST_CHUNK;
+$num_test_files = 10 if $num_test_files > 10;
+
+my $property_count = -1;
+foreach my $name (sort keys %properties, 'octal') {
+
+    # We test every nth property in this run so that this test is split into
+    # smaller chunks to minimize test suite elapsed time when run in parallel.
+    $property_count++;
+    next if $property_count % $num_test_files != $::TEST_CHUNK;
+
+    my @invlist;
+    if ($name eq 'octal') {
+        # Hand-roll an inversion list with 0-7 in it and nothing else.
+        push @invlist, ord "0", ord "8";
+    }
+    else {
+        my $property = $properties{$name};
+        @invlist = prop_invlist($property, '_perl_core_internal_ok');
+        if (! @invlist) {
+
+            # An empty return could mean an unknown property, or merely that
+            # it is empty.  Call in scalar context to differentiate
+            if (! prop_invlist($property, '_perl_core_internal_ok')) {
+                fail("No inversion list found for $property");
+                next;
+            }
+        }
+    }
+
+    # Include all the Latin1 code points, plus 0x100.
+    my @code_points = (0 .. 256);
+
+    # Then include the next few boundaries above those from this property
+    my $above_latins = 0;
+    foreach my $range_start (@invlist) {
+        next if $range_start < 257;
+        push @code_points, $range_start - 1, $range_start;
+        $above_latins++;
+        last if $above_latins > 5;
+    }
+
+    # This makes sure we are using the Perl definition of idfirst and idcont,
+    # and not the Unicode.  There are a few differences.
+    push @code_points, ord "\N{ESTIMATED SYMBOL}" if $name =~ /^id(first|cont)/;
+    if ($name eq "idcont") {    # And some that are continuation but not start
+        push @code_points, ord("\N{GREEK ANO TELEIA}"),
+                           ord("\N{COMBINING GRAVE ACCENT}");
+    }
+
+    # And finally one non-Unicode code point.
+    push @code_points, 0x110000;    # Above Unicode, no prop should match
+    no warnings 'non_unicode';
+
+    for my $n (@code_points) {
+        my $u = utf8::native_to_unicode($n);
+        my $function = uc($name);
+
+        is (@warnings, 0, "Got no unexpected warnings in previous iteration")
+           or diag("@warnings");
+        undef @warnings;
+
+        my $matches = search_invlist(\@invlist, $n);
+        if (! defined $matches) {
+            $matches = 0;
+        }
+        else {
+            $matches = truth(! ($matches % 2));
+        }
+
+        my $ret;
+        my $char_name = get_charname($n);
+        my $display_name = sprintf "\\x{%02X, %s}", $n, $char_name;
+        my $display_call = "is${function}( $display_name )";
+
+        foreach my $suffix ("", "_A", "_L1", "_LC", "_uni", "_uvchr",
+                            "_LC_uvchr", "_utf8", "_LC_utf8")
+        {
+
+            # Not all possible macros have been defined
+            if ($name eq 'vertws') {
+
+                # vertws is always all of Unicode
+                next if $suffix !~ / ^ _ ( uni | uvchr | utf8 ) $ /x;
+            }
+            elsif ($name eq 'alnum') {
+
+                # ALNUM_A, ALNUM_L1, and ALNUM_uvchr are not defined as these
+                # suffixes were added later, after WORDCHAR was created to be
+                # a clearer synonym for ALNUM
+                next if    $suffix eq '_A'
+                        || $suffix eq '_L1'
+                        || $suffix eq '_uvchr';
+            }
+            elsif ($name eq 'octal') {
+                next if $suffix ne ""  && $suffix ne '_A' && $suffix ne '_L1';
+            }
+            elsif ($name eq 'quotemeta') {
+                # There is only one macro for this, and is defined only for
+                # Latin1 range
+                next if $suffix ne ""
+            }
+
+            foreach my $locale ("", $base_locale, $utf8_locale) {
+
+                my ($display_locale, $locale_is_utf8)
+                                = get_display_locale_or_skip($locale, $suffix);
+                next unless defined $display_locale;
+
+                use if $locale, "locale";
+                POSIX::setlocale( &POSIX::LC_ALL, $locale) if $locale;
+
+                if ($suffix !~ /utf8/) {    # _utf8 has to handled specially
+                    my $display_call
+                       = "is${function}$suffix( $display_name )$display_locale";
+                    $ret = truth eval "test_is${function}$suffix($n)";
+                    if (is ($@, "", "$display_call didn't give error")) {
+                        my $truth = $matches;
+                        if ($truth) {
+
+                            # The single byte functions are false for
+                            # above-Latin1
+                            if ($n >= 256) {
+                                $truth = 0
+                                        if $suffix=~ / ^ ( _A | _L [1C] )? $ /x;
+                            }
+                            elsif (   $u >= 128
+                                   && $name ne 'quotemeta')
+                            {
+
+                                # The no-suffix and _A functions are false
+                                # for non-ASCII.  So are  _LC  functions on a
+                                # non-UTF-8 locale
+                                $truth = 0 if    $suffix eq "_A"
+                                              || $suffix eq ""
+                                              || (     $suffix =~ /LC/
+                                                  && ! $locale_is_utf8);
+                            }
+                        }
+
+                        is ($ret, $truth, "${tab}And correctly returns $truth");
+                    }
+                }
+                else {  # _utf8 suffix
+                    my $char = chr($n);
+                    utf8::upgrade($char);
+                    $char = quotemeta $char if $char eq '\\' || $char eq "'";
+                    my $truth;
+                    if (   $suffix =~ /LC/
+                        && ! $locale_is_utf8
+                        && $n < 256
+                        && $u >= 128)
+                    {   # The C-locale _LC function returns FALSE for Latin1
+                        # above ASCII
+                        $truth = 0;
+                    }
+                    else {
+                        $truth = $matches;
+                    }
+
+                    foreach my $utf8_param("_safe",
+                                           "_safe, malformed",
+                                           "deprecated unsafe"
+                                          )
+                    {
+                        my $utf8_param_code = $utf8_param_code{$utf8_param};
+                        my $expect_error = $utf8_param_code > 0;
+                        next if      $expect_error
+                                && ! try_malforming($u, $function,
+                                                    $suffix =~ /LC/);
+
+                        my $display_call = "is${function}$suffix( $display_name"
+                                         . ", $utf8_param )$display_locale";
+                        $ret = truth eval "test_is${function}$suffix('$char',"
+                                        . " $utf8_param_code)";
+                        if ($expect_error) {
+                            isnt ($@, "",
+                                    "expected and got error in $display_call");
+                            like($@, qr/Malformed UTF-8 character/,
+                                "${tab}And got expected message");
+                            if (is (@warnings, 1,
+                                           "${tab}Got a single warning besides"))
+                            {
+                                like($warnings[0],
+                                     qr/Malformed UTF-8 character.*short/,
+                                     "${tab}Got expected warning");
+                            }
+                            else {
+                                diag("@warnings");
+                            }
+                            undef @warnings;
+                        }
+                        elsif (is ($@, "", "$display_call didn't give error")) {
+                            is ($ret, $truth,
+                                "${tab}And correctly returned $truth");
+                            if ($utf8_param_code < 0) {
+                                my $warnings_ok;
+                                my $unique_function = "is" . $function . $suffix;
+                                if (! $seen{$unique_function}++) {
+                                    $warnings_ok = is(@warnings, 1,
+                                        "${tab}This is first call to"
+                                      . " $unique_function; Got a single"
+                                      . " warning");
+                                    if ($warnings_ok) {
+                                        $warnings_ok = like($warnings[0],
+                qr/starting in Perl .* will require an additional parameter/,
+                                            "${tab}The warning was the expected"
+                                          . " deprecation one");
+                                    }
+                                }
+                                else {
+                                    $warnings_ok = is(@warnings, 0,
+                                        "${tab}This subsequent call to"
+                                      . " $unique_function did not warn");
+                                }
+                                $warnings_ok or diag("@warnings");
+                                undef @warnings;
+                            }
+                        }
+                    }
+                }
+            }
+        }
+    }
+}
+
+my %to_properties = (
+                FOLD  => 'Case_Folding',
+                LOWER => 'Lowercase_Mapping',
+                TITLE => 'Titlecase_Mapping',
+                UPPER => 'Uppercase_Mapping',
+            );
+
+$property_count = -1;
+foreach my $name (sort keys %to_properties) {
+
+    $property_count++;
+    next if $property_count % $num_test_files != $::TEST_CHUNK;
+
+    my $property = $to_properties{$name};
+    my ($list_ref, $map_ref, $format, $missing)
+                                      = prop_invmap($property, );
+    if (! $list_ref || ! $map_ref) {
+        fail("No inversion map found for $property");
+        next;
+    }
+    if ($format !~ / ^ a l? $ /x) {
+        fail("Unexpected inversion map format ('$format') found for $property");
+        next;
+    }
+
+    # Include all the Latin1 code points, plus 0x100.
+    my @code_points = (0 .. 256);
+
+    # Then include the next few multi-char folds above those from this
+    # property, and include the next few single folds as well
+    my $above_latins = 0;
+    my $multi_char = 0;
+    for my $i (0 .. @{$list_ref} - 1) {
+        my $range_start = $list_ref->[$i];
+        next if $range_start < 257;
+        if (ref $map_ref->[$i] && $multi_char < 5)  {
+            push @code_points, $range_start - 1
+                                        if $code_points[-1] != $range_start - 1;
+            push @code_points, $range_start;
+            $multi_char++;
+        }
+        elsif ($above_latins < 5) {
+            push @code_points, $range_start - 1
+                                        if $code_points[-1] != $range_start - 1;
+            push @code_points, $range_start;
+            $above_latins++;
+        }
+        last if $above_latins >= 5 && $multi_char >= 5;
+    }
+
+    # And finally one non-Unicode code point.
+    push @code_points, 0x110000;    # Above Unicode, no prop should match
+    no warnings 'non_unicode';
+
+    # $n is native; $u unicode.
+    for my $n (@code_points) {
+        my $u = utf8::native_to_unicode($n);
+        my $function = $name;
+
+        my $index = search_invlist(\@{$list_ref}, $n);
+
+        my $ret;
+        my $char_name = get_charname($n);
+        my $display_name = sprintf "\\N{U+%02X, %s}", $n, $char_name;
+
+        foreach my $suffix ("", "_L1", "_LC") {
+
+            # This is the only macro defined for L1
+            next if $suffix eq "_L1" && $function ne "LOWER";
+
+          SKIP:
+            foreach my $locale ("", $base_locale, $utf8_locale) {
+
+                # titlecase is not defined in locales.
+                next if $name eq 'TITLE' && $suffix eq "_LC";
+
+                my ($display_locale, $locale_is_utf8)
+                                = get_display_locale_or_skip($locale, $suffix);
+                next unless defined $display_locale;
+
+                skip("to${name}_LC does not work for LATIN SMALL LETTER SHARP S"
+                  . "$display_locale", 1)
+                            if  $u == 0xDF && $name =~ / FOLD | UPPER /x
+                             && $suffix eq "_LC" && $locale_is_utf8;
+
+                use if $locale, "locale";
+                POSIX::setlocale( &POSIX::LC_ALL, $locale) if $locale;
+
+                my $display_call = "to${function}$suffix("
+                                 . " $display_name )$display_locale";
+                $ret = eval "test_to${function}$suffix($n)";
+                if (is ($@, "", "$display_call didn't give error")) {
+                    my $should_be;
+                    if ($n > 255) {
+                        $should_be = $n;
+                    }
+                    elsif (     $u > 127
+                            && (   $suffix eq ""
+                                || ($suffix eq "_LC" && ! $locale_is_utf8)))
+                    {
+                        $should_be = $n;
+                    }
+                    elsif ($map_ref->[$index] != $missing) {
+                        $should_be = $map_ref->[$index] + $n - $list_ref->[$index]
+                    }
+                    else {
+                        $should_be = $n;
+                    }
+
+                    is ($ret, $should_be,
+                        sprintf("${tab}And correctly returned 0x%02X",
+                                                              $should_be));
+                }
+            }
+        }
+
+        # The _uni, uvchr, and _utf8 functions return both the ordinal of the
+        # first code point of the result, and the result in utf8.  The .xs
+        # tests return these in an array, in [0] and [1] respectively, with
+        # [2] the length of the utf8 in bytes.
+        my $utf8_should_be = "";
+        my $first_ord_should_be;
+        if (ref $map_ref->[$index]) {   # A multi-char result
+            for my $n (0 .. @{$map_ref->[$index]} - 1) {
+                $utf8_should_be .= chr $map_ref->[$index][$n];
+            }
+
+            $first_ord_should_be = $map_ref->[$index][0];
+        }
+        else {  # A single-char result
+            $first_ord_should_be = ($map_ref->[$index] != $missing)
+                                    ? $map_ref->[$index] + $n
+                                                         - $list_ref->[$index]
+                                    : $n;
+            $utf8_should_be = chr $first_ord_should_be;
+        }
+        utf8::upgrade($utf8_should_be);
+
+        # Test _uni, uvchr
+        foreach my $suffix ('_uni', '_uvchr') {
+            my $s;
+            my $len;
+            my $display_call = "to${function}$suffix( $display_name )";
+            $ret = eval "test_to${function}$suffix($n)";
+            if (is ($@, "", "$display_call didn't give error")) {
+                is ($ret->[0], $first_ord_should_be,
+                    sprintf("${tab}And correctly returned 0x%02X",
+                                                    $first_ord_should_be));
+                is ($ret->[1], $utf8_should_be, "${tab}Got correct utf8");
+                use bytes;
+                is ($ret->[2], length $utf8_should_be,
+                    "${tab}Got correct number of bytes for utf8 length");
+            }
+        }
+
+        # Test _utf8
+        my $char = chr($n);
+        utf8::upgrade($char);
+        $char = quotemeta $char if $char eq '\\' || $char eq "'";
+        foreach my $utf8_param("_safe",
+                                "_safe, malformed",
+                                "deprecated unsafe",
+                                "deprecated mathoms",
+                                )
+        {
+            use Config;
+            next if    $utf8_param eq 'deprecated mathoms'
+                    && $Config{'ccflags'} =~ /-DNO_MATHOMS/;
+
+            my $utf8_param_code = $utf8_param_code{$utf8_param};
+            my $expect_error = $utf8_param_code > 0;
+
+            # Skip if can't malform (because is a UTF-8 invariant)
+            next if $expect_error && $u < ((ord "A" == 65) ? 128 : 160);
+
+            my $display_call = "to${function}_utf8($display_name, $utf8_param )";
+            $ret = eval   "test_to${function}_utf8('$char', $utf8_param_code)";
+            if ($expect_error) {
+                isnt ($@, "", "expected and got error in $display_call");
+                like($@, qr/Malformed UTF-8 character/,
+                     "${tab}And got expected message");
+                undef @warnings;
+            }
+            elsif (is ($@, "", "$display_call didn't give error")) {
+                is ($ret->[0], $first_ord_should_be,
+                    sprintf("${tab}And correctly returned 0x%02X",
+                                                    $first_ord_should_be));
+                is ($ret->[1], $utf8_should_be, "${tab}Got correct utf8");
+                use bytes;
+                is ($ret->[2], length $utf8_should_be,
+                    "${tab}Got correct number of bytes for utf8 length");
+                if ($utf8_param_code < 0) {
+                    my $warnings_ok;
+                    if (! $seen{"${function}_utf8$utf8_param"}++) {
+                        $warnings_ok = is(@warnings, 1,
+                                                   "${tab}Got a single warning");
+                        if ($warnings_ok) {
+                            my $expected;
+                            if ($utf8_param_code == -2) {
+                                my $lc_func = lc $function;
+                                $expected
+                = qr/starting in Perl .* to_utf8_$lc_func\(\) will be removed/;
+                            }
+                            else {
+                                $expected
+                = qr/starting in Perl .* will require an additional parameter/;
+                            }
+                            $warnings_ok = like($warnings[0], $expected,
+                                      "${tab}Got expected deprecation warning");
+                        }
+                    }
+                    else {
+                        $warnings_ok = is(@warnings, 0,
+                                  "${tab}Deprecation warned only the one time");
+                    }
+                    $warnings_ok or diag("@warnings");
+                    undef @warnings;
+                }
+            }
+        }
+    }
+}
+
+# This is primarily to make sure that no non-Unicode warnings get generated
+is(scalar @warnings, 0, "No unexpected warnings were generated in the tests")
+  or diag @warnings;
+
+done_testing;
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/keyword_plugin_threads.t b/gnu/usr.bin/perl/ext/XS-APItest/t/keyword_plugin_threads.t
new file mode 100644
index 00000000000..db23ce7d58c
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/keyword_plugin_threads.t
@@ -0,0 +1,32 @@
+#!perl
+use strict;
+use warnings;
+
+require '../../t/test.pl';
+
+use Config;
+if (!$Config{useithreads}) {
+    skip_all("keyword_plugin thread test requires threads");
+}
+
+plan(1);
+
+fresh_perl_is( <<'----', <<'====', {}, "loading XS::APItest in threads works");
+use strict;
+use warnings;
+
+use threads;
+
+require '../../t/test.pl';
+watchdog(5);
+
+for my $t (1 .. 3) {
+    threads->create(sub {
+        require XS::APItest;
+    })->join;
+}
+
+print "all is well\n";
+----
+all is well
+====
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/labelconst.t b/gnu/usr.bin/perl/ext/XS-APItest/t/labelconst.t
index f3a7d9c9cd0..aed3afbd1af 100644
--- a/gnu/usr.bin/perl/ext/XS-APItest/t/labelconst.t
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/labelconst.t
@@ -89,7 +89,7 @@ isnt $@, "";
 is $t, "";
 
 $t = "";
-$t = do("t/labelconst.aux");
+$t = do("./t/labelconst.aux");
 is $@, "";
 is $t, "FOOBARBAZQUUX";
 
@@ -163,7 +163,7 @@ is $t, "FOOBARBAZQUUX";
 {
     use utf8;
     $t = "";
-    $t = do("t/labelconst_utf8.aux");
+    $t = do("./t/labelconst_utf8.aux");
     is $@, "";
     is $t, "ＦǑǑBÀRᛒÀZQÙÙX";
 }
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/lexsub.t b/gnu/usr.bin/perl/ext/XS-APItest/t/lexsub.t
index 2d66addf7a2..25985f60b4b 100644
--- a/gnu/usr.bin/perl/ext/XS-APItest/t/lexsub.t
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/lexsub.t
@@ -1,4 +1,4 @@
-use Test::More tests => 4;
+use Test::More tests => 5;
 use XS::APItest;
 
 
@@ -17,3 +17,14 @@ is fribbler(15), 30, 'XS-allocated lexical subs falling out of scope';
     our sub fribbler;
     is fribbler(15), 30, 'our sub overrides XS-registered lexical sub';
 }
+
+# With ‘use’ rather than explicit BEGIN:
+package Lexical::Exporter {
+    sub import { shift; ::lexical_import @_; return }
+}
+BEGIN { ++$INC{"Lexical/Exporter.pm"} }
+
+{
+    use Lexical::Exporter fribbler => sub { shift() . "foo" };
+    is fribbler("bar"), "barfoo";
+}
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/load-module.t b/gnu/usr.bin/perl/ext/XS-APItest/t/load-module.t
new file mode 100644
index 00000000000..78189f80e73
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/load-module.t
@@ -0,0 +1,66 @@
+#!perl -w
+use strict;
+
+# Test the load_module() core API function.
+#
+# Note that this function can be passed arbitrary and illegal module
+# names which would already have been caught if a require statement had
+# been compiled. So check that load_module() can catch such bad things.
+
+use Test::More;
+use XS::APItest;
+
+# This isn't complete yet. In particular, we don't test import lists, or
+# the other flags. But it's better than nothing.
+
+is($INC{'less.pm'}, undef, "less isn't loaded");
+load_module(PERL_LOADMOD_NOIMPORT, 'less');
+like($INC{'less.pm'}, qr!(?:\A|/)lib/less\.pm\z!, "less is now loaded");
+
+delete $INC{'less.pm'};
+delete $::{'less::'};
+
+is(eval { load_module(PERL_LOADMOD_NOIMPORT, 'less', 1); 1}, undef,
+   "expect load_module() to fail");
+like($@, qr/less version 1 required--this is only version 0\./,
+     'with the correct error message');
+
+is(eval { load_module(PERL_LOADMOD_NOIMPORT, 'less', 0.03); 1}, 1,
+   "expect load_module() not to fail");
+
+#
+# Check for illegal module names
+
+for (["", qr!\ABareword in require maps to empty filename!],
+    ["::", qr!\ABareword in require must not start with a double-colon: "::"!],
+    ["::::", qr!\ABareword in require must not start with a double-colon: "::::"!],
+    ["::/", qr!\ABareword in require must not start with a double-colon: "::/!],
+    ["/", qr!\ABareword in require maps to disallowed filename "/\.pm"!],
+    ["::/WOOSH", qr!\ABareword in require must not start with a double-colon: "::/WOOSH!],
+    [".WOOSH", qr!\ABareword in require maps to disallowed filename "\.WOOSH\.pm"!],
+    ["::.WOOSH", qr!\ABareword in require must not start with a double-colon: "::.WOOSH!],
+    ["WOOSH::.sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH::.sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH/.sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH/..sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH/../sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH::..::sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH::.::sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH::./sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH/./sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH/.::sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH/..::sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH::../sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH::../..::sock", qr!\ABareword in require contains "/\."!],
+    ["WOOSH\0sock", qr!\ACan't locate WOOSH\\0sock.pm:!],
+    )
+{
+    my ($module, $error) = @$_;
+    my $module2 = $module; # load_module mangles its first argument
+    no warnings 'syscalls';
+    is(eval { load_module(PERL_LOADMOD_NOIMPORT, $module); 1}, undef,
+       "expect load_module() for '$module2' to fail");
+    like($@, $error, "check expected error for $module2");
+}
+
+done_testing();
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/loopblock.t b/gnu/usr.bin/perl/ext/XS-APItest/t/loopblock.t
index 3b688bc811a..7f654a5424c 100644
--- a/gnu/usr.bin/perl/ext/XS-APItest/t/loopblock.t
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/loopblock.t
@@ -70,7 +70,7 @@ eval q{
 	my $x = "a";
 	$t .= $x;
 	do {
-		no warnings "misc";
+		no warnings "shadow";
 		$t .= $x;
 		my $x = "b";
 		$t .= $x;
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/looprest.t b/gnu/usr.bin/perl/ext/XS-APItest/t/looprest.t
index e37ef87941a..aa3116daa84 100644
--- a/gnu/usr.bin/perl/ext/XS-APItest/t/looprest.t
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/looprest.t
@@ -66,7 +66,7 @@ eval q{
 	my $x = "a";
 	$t .= $x;
 	do {
-		no warnings "misc";
+		no warnings "shadow";
 		$t .= $x;
 		my $x = "b";
 		$t .= $x;
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/sviscow.t b/gnu/usr.bin/perl/ext/XS-APItest/t/sviscow.t
index bcc9da8ebdc..d0f3062f5d8 100644
--- a/gnu/usr.bin/perl/ext/XS-APItest/t/sviscow.t
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/sviscow.t
@@ -1,10 +1,10 @@
 use strict;
-use warnings; no warnings 'once';
 
 use Test::More tests => 1;
 
 use XS::APItest;
 use Hash::Util 'lock_value';
+use warnings; no warnings 'once', 'Hash::Util';
 
 my %h;
 $h{g} = *foo;
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf16_to_utf8.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf16_to_utf8.t
index 1829dd5fcda..3bb78d49524 100755
--- a/gnu/usr.bin/perl/ext/XS-APItest/t/utf16_to_utf8.t
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf16_to_utf8.t
@@ -14,7 +14,8 @@ for my $ord (0, 10, 13, 78, 255, 256, 0xD7FF, 0xE000, 0xFFFD,
 	    my $string = $prefix . $chr . $suffix;
 	    my $name = sprintf "for chr $ord prefix %d, suffix %d",
 		length $prefix, length $suffix;
-	    my $as_utf8 = encode('UTF-8', $string);
+	    my $as_utf8 = $string;
+	    utf8::encode($as_utf8);
 	    is(utf16_to_utf8(encode('UTF-16BE', $string)), $as_utf8,
 	       "utf16_to_utf8 $name");
 	    is(utf16_to_utf8_reversed(encode('UTF-16LE', $string)), $as_utf8,
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_setup.pl b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_setup.pl
new file mode 100644
index 00000000000..231b4d9494c
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_setup.pl
@@ -0,0 +1,112 @@
+# Common subroutines and constants, called by .t files in this directory that
+# deal with UTF-8
+
+# The  test files can't use byte_utf8a_to_utf8n() from t/charset_tools.pl
+# because that uses the same functions we are testing here.  So UTF-EBCDIC
+# strings are hard-coded as I8 strings in this file instead, and we use the
+# translation functions to/from I8 from that file instead.
+
+sub isASCII { ord "A" == 65 }
+
+sub display_bytes_no_quotes {
+    use bytes;
+    my $string = shift;
+    return join("", map {
+                          ($_ =~ /[[:print:]]/)
+                          ? $_
+                          : sprintf("\\x%02x", ord $_)
+                        } split "", $string)
+}
+
+sub display_bytes {
+    return   '"' . display_bytes_no_quotes(shift) . '"';
+}
+
+sub output_warnings(@) {
+    my @list = @_;
+    if (@list) {
+        diag "The warnings were:\n" . join "\n", map { chomp; $_ } @list;
+    }
+    else {
+        diag "No warnings were raised";
+    }
+}
+
+sub start_byte_to_cont($) {
+
+    # Extract the code point information from the input UTF-8 start byte, and
+    # return a continuation byte containing the same information.  This is
+    # used in constructing an overlong malformation from valid input.
+
+    my $byte = shift;
+    my $len = test_UTF8_SKIP($byte);
+    if ($len < 2) {
+        die "start_byte_to_cont() is expecting a UTF-8 variant";
+    }
+
+    $byte = ord native_to_I8($byte);
+
+    # Copied from utf8.h.  This gets rid of the leading 1 bits.
+    $byte &= ((($len) >= 7) ? 0x00 : (0x1F >> (($len)-2)));
+
+    $byte |= (isASCII) ? 0x80 : 0xA0;
+    return I8_to_native(chr $byte);
+}
+
+$::is64bit = length sprintf("%x", ~0) > 8;
+
+$::lowest_continuation = (isASCII) ? 0x80 : 0xA0;
+
+$::I8c = (isASCII) ? "\x80" : "\xa0";    # A continuation byte
+
+
+$::max_bytes = (isASCII) ? 13 : 14; # Max number of bytes in a UTF-8 sequence
+                                    # representing a single code point
+
+# Copied from utf8.h
+$::UTF8_ALLOW_EMPTY            = 0x0001;
+$::UTF8_GOT_EMPTY              = $UTF8_ALLOW_EMPTY;
+$::UTF8_ALLOW_CONTINUATION     = 0x0002;
+$::UTF8_GOT_CONTINUATION       = $UTF8_ALLOW_CONTINUATION;
+$::UTF8_ALLOW_NON_CONTINUATION = 0x0004;
+$::UTF8_GOT_NON_CONTINUATION   = $UTF8_ALLOW_NON_CONTINUATION;
+$::UTF8_ALLOW_SHORT            = 0x0008;
+$::UTF8_GOT_SHORT              = $UTF8_ALLOW_SHORT;
+$::UTF8_ALLOW_LONG             = 0x0010;
+$::UTF8_ALLOW_LONG_AND_ITS_VALUE = $UTF8_ALLOW_LONG|0x0020;
+$::UTF8_GOT_LONG               = $UTF8_ALLOW_LONG;
+$::UTF8_ALLOW_OVERFLOW         = 0x0080;
+$::UTF8_GOT_OVERFLOW           = $UTF8_ALLOW_OVERFLOW;
+$::UTF8_DISALLOW_SURROGATE     = 0x0100;
+$::UTF8_GOT_SURROGATE          = $UTF8_DISALLOW_SURROGATE;
+$::UTF8_WARN_SURROGATE         = 0x0200;
+$::UTF8_DISALLOW_NONCHAR       = 0x0400;
+$::UTF8_GOT_NONCHAR            = $UTF8_DISALLOW_NONCHAR;
+$::UTF8_WARN_NONCHAR           = 0x0800;
+$::UTF8_DISALLOW_SUPER         = 0x1000;
+$::UTF8_GOT_SUPER              = $UTF8_DISALLOW_SUPER;
+$::UTF8_WARN_SUPER             = 0x2000;
+$::UTF8_DISALLOW_PERL_EXTENDED  = 0x4000;
+$::UTF8_GOT_PERL_EXTENDED       = $UTF8_DISALLOW_PERL_EXTENDED;
+$::UTF8_WARN_PERL_EXTENDED      = 0x8000;
+$::UTF8_CHECK_ONLY             = 0x10000;
+$::UTF8_NO_CONFIDENCE_IN_CURLEN_ = 0x20000;
+
+$::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE
+                             = $UTF8_DISALLOW_SUPER|$UTF8_DISALLOW_SURROGATE;
+$::UTF8_DISALLOW_ILLEGAL_INTERCHANGE
+              = $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE|$UTF8_DISALLOW_NONCHAR;
+$::UTF8_WARN_ILLEGAL_C9_INTERCHANGE
+                             = $UTF8_WARN_SUPER|$UTF8_WARN_SURROGATE;
+$::UTF8_WARN_ILLEGAL_INTERCHANGE
+              = $UTF8_WARN_ILLEGAL_C9_INTERCHANGE|$UTF8_WARN_NONCHAR;
+
+# Test uvchr_to_utf8().
+$::UNICODE_WARN_SURROGATE        = 0x0001;
+$::UNICODE_WARN_NONCHAR          = 0x0002;
+$::UNICODE_WARN_SUPER            = 0x0004;
+$::UNICODE_WARN_PERL_EXTENDED     = 0x0008;
+$::UNICODE_DISALLOW_SURROGATE    = 0x0010;
+$::UNICODE_DISALLOW_NONCHAR      = 0x0020;
+$::UNICODE_DISALLOW_SUPER        = 0x0040;
+$::UNICODE_DISALLOW_PERL_EXTENDED = 0x0080;
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_to_bytes.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_to_bytes.t
new file mode 100644
index 00000000000..4c03f842f53
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_to_bytes.t
@@ -0,0 +1,68 @@
+#!perl -w
+
+# This is a base file to be used by various .t's in its directory
+# It tests various malformed UTF-8 sequences and some code points that are
+# "problematic", and verifies that the correct warnings/flags etc are
+# generated when using them.  For the code points, it also takes the UTF-8 and
+# perturbs it to be malformed in various ways, and tests that this gets
+# appropriately detected.
+
+use strict;
+use Test::More;
+
+BEGIN {
+    require './t/utf8_setup.pl';
+    use_ok('XS::APItest');
+};
+
+$|=1;
+
+use Data::Dumper;
+
+my @well_formed = (
+            "\xE1",
+            "The quick brown fox jumped over the lazy dog",
+            "Ces systèmes de codage sont souvent incompatibles entre eux.  Ainsi, deux systèmes peuvent utiliser le même nombre pour deux caractères différents ou utiliser différents nombres pour le même caractère.",
+            "Kelimelerin m\xC3\xAAme caract\xC3\xA8re ve yaz\xC3\xB1abc",
+);
+
+my @malformed = (
+            "Kelimelerin m\xC3\xAAme caract\xC3\xA8re ve yaz\xC4\xB1abc",
+            "Kelimelerin m\xC3\xAAme caract\xC3\xA8re ve yaz\xC4\xB1\xC3\xA8abc",
+            "Kelimelerin m\xC3\xAAme caract\xC3re ve yazi\xC3\xA8abc",
+            "Kelimelerin m\xC3\xAAme caract\xA8 ve yazi\xC3\xA8abc",
+            "Kelimelerin m\xC3\xAAme caract\xC3\xA8\xC3re ve yazi\xC3\xA8abc",
+);
+
+for my $test (@well_formed) {
+    my $utf8 = $test;
+    utf8::upgrade($utf8);
+    my $utf8_length;
+    my $byte_length = length $test;
+
+    {
+        use bytes;
+        $utf8_length = length $utf8;
+    }
+
+    my $ret_ref = test_utf8_to_bytes($utf8, $utf8_length);
+
+    is ($ret_ref->[0], $test, "Successfully downgraded "
+                            . display_bytes($utf8));
+    is ($ret_ref->[1], $byte_length, "... And returned correct length("
+                                     . $byte_length . ")");
+}
+
+for my $test (@malformed) {
+    my $utf8 = $test;
+    my $utf8_length = length $test;
+
+    my $ret_ref = test_utf8_to_bytes($utf8, $utf8_length);
+
+    ok (! defined $ret_ref->[0], "Returned undef for malformed "
+                                . display_bytes($utf8));
+    is ($ret_ref->[1], -1, "... And returned length -1");
+    is ($ret_ref->[2], $utf8, "... And left the input unchanged");
+}
+
+done_testing();
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn00.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn00.t
new file mode 100644
index 00000000000..3f91bf5a4e9
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn00.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 0;
+
+do './t/utf8_warn_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn01.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn01.t
new file mode 100644
index 00000000000..beb4faf634c
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn01.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 1;
+
+do './t/utf8_warn_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn02.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn02.t
new file mode 100644
index 00000000000..d6d3e7a73dc
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn02.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 2;
+
+do './t/utf8_warn_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn03.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn03.t
new file mode 100644
index 00000000000..ae0da886c94
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn03.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 3;
+
+do './t/utf8_warn_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn04.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn04.t
new file mode 100644
index 00000000000..52e82508510
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn04.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 4;
+
+do './t/utf8_warn_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn05.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn05.t
new file mode 100644
index 00000000000..94f8f0cd458
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn05.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 5;
+
+do './t/utf8_warn_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn06.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn06.t
new file mode 100644
index 00000000000..5995db6906b
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn06.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 6;
+
+do './t/utf8_warn_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn07.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn07.t
new file mode 100644
index 00000000000..27dc96bc2f4
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn07.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 7;
+
+do './t/utf8_warn_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn08.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn08.t
new file mode 100644
index 00000000000..01de3b67a3f
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn08.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 8;
+
+do './t/utf8_warn_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn09.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn09.t
new file mode 100644
index 00000000000..aa4c42f9120
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn09.t
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 9;
+
+do './t/utf8_warn_base.pl';
diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn_base.pl b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn_base.pl
new file mode 100644
index 00000000000..0c9e20b9cac
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8_warn_base.pl
@@ -0,0 +1,1880 @@
+#!perl -w
+
+# This is a base file to be used by various .t's in its directory
+# It tests various malformed UTF-8 sequences and some code points that are
+# "problematic", and verifies that the correct warnings/flags etc are
+# generated when using them.  For the code points, it also takes the UTF-8 and
+# perturbs it to be malformed in various ways, and tests that this gets
+# appropriately detected.
+
+use strict;
+use Test::More;
+
+BEGIN {
+    use_ok('XS::APItest');
+    require 'charset_tools.pl';
+    require './t/utf8_setup.pl';
+};
+
+$|=1;
+
+use XS::APItest;
+
+my @warnings_gotten;
+
+use warnings 'utf8';
+local $SIG{__WARN__} = sub { my @copy = @_;
+                             push @warnings_gotten, map { chomp; $_ } @copy;
+                           };
+
+my $highest_non_extended_utf8_cp = (isASCII) ? 0x7FFFFFFF : 0x3FFFFFFF;
+my $native_lowest_continuation_chr = I8_to_native(chr $::lowest_continuation);
+
+# C5 is chosen as it is valid for both ASCII and EBCDIC platforms
+my $known_start_byte = I8_to_native("\xC5");
+
+sub requires_extended_utf8($) {
+
+    # Returns a boolean as to whether or not the code point parameter fits
+    # into 31 bits, subject to the convention that a negative code point
+    # stands for one that overflows the word size, so won't fit in 31 bits.
+
+    return shift > $highest_non_extended_utf8_cp;
+}
+
+sub is_extended_utf8($) {
+
+    # Returns a boolean as to whether or not the input UTF-8 sequence uses
+    # Perl extended UTF-8.
+
+    my $byte = substr(shift, 0, 1);
+    return ord $byte >= 0xFE if isASCII;
+    return $byte == I8_to_native("\xFF");
+}
+
+sub overflow_discern_len($) {
+
+    # Returns how many bytes are needed to tell if a non-overlong UTF-8
+    # sequence is for a code point that won't fit in the platform's word size.
+    # Only the length of the sequence representing a single code point is
+    # needed.
+
+    if (isASCII) {
+        return ($::is64bit) ? 3 : 1;
+
+        # Below is needed for code points above IV_MAX
+        #return ($::is64bit) ? 3 : ((shift == $::max_bytes)
+        #                           ? 1
+        #                           : 2);
+    }
+
+    return ($::is64bit) ? 2 : 8;
+}
+
+sub overlong_discern_len($) {
+
+    # Returns how many bytes are needed to tell if the input UTF-8 sequence
+    # for a code point is overlong
+
+    my $string = shift;
+    my $length = length $string;
+    my $byte = ord native_to_I8(substr($string, 0, 1));
+    if (isASCII) {
+        return ($byte >= 0xFE)
+                ? ((! $::is64bit)
+                    ? 1
+                    : ($byte == 0xFF) ? 7 : 2)
+                : (($length == 2) ? 1 : 2);
+        # Below is needed for code points above IV_MAX
+        #return ($length == $::max_bytes)
+        #          # This is constrained to 1 on 32-bit machines, as it
+        #          # overflows there
+        #        ? (($::is64bit) ? 7 : 1)
+        #        : (($length == 2) ? 1 : 2);
+    }
+
+    return ($length == $::max_bytes) ? 8 : (($length <= 3) ? 1 : 2);
+}
+
+my @tests;
+{
+    no warnings qw(portable overflow);
+    @tests = (
+        # $testname,
+        # $bytes,                  UTF-8 string
+        # $allowed_uv,             code point $bytes evaluates to; -1 if
+        #                          overflows
+        # $needed_to_discern_len   optional, how long an initial substring do
+        #                          we need to tell that the string must be for
+        #                          a code point in the category it falls in,
+        #                          like being a surrogate; 0 indicates we need
+        #                          the whole string.  Some categories have a
+        #                          default that is used if this is omitted.
+        [ "orphan continuation byte malformation",
+            I8_to_native("$::I8c"),
+            0xFFFD,
+            1,
+        ],
+        [ "overlong malformation, lowest 2-byte",
+            (isASCII) ? "\xc0\x80" : I8_to_native("\xc0\xa0"),
+            0,   # NUL
+        ],
+        [ "overlong malformation, highest 2-byte",
+            (isASCII) ? "\xc1\xbf" : I8_to_native("\xc4\xbf"),
+            (isASCII) ? 0x7F : 0xFF,
+        ],
+        [ "overlong malformation, lowest 3-byte",
+            (isASCII) ? "\xe0\x80\x80" : I8_to_native("\xe0\xa0\xa0"),
+            0,   # NUL
+        ],
+        [ "overlong malformation, highest 3-byte",
+            (isASCII) ? "\xe0\x9f\xbf" : I8_to_native("\xe0\xbf\xbf"),
+            (isASCII) ? 0x7FF : 0x3FF,
+        ],
+        [ "lowest surrogate",
+            (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
+            0xD800,
+        ],
+        [ "a middle surrogate",
+            (isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"),
+            0xD90D,
+        ],
+        [ "highest surrogate",
+            (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
+            0xDFFF,
+        ],
+        [ "first of 32 consecutive non-character code points",
+            (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
+            0xFDD0,
+        ],
+        [ "a mid non-character code point of the 32 consecutive ones",
+            (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
+            0xFDE0,
+        ],
+        [ "final of 32 consecutive non-character code points",
+            (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
+            0xFDEF,
+        ],
+        [ "non-character code point U+FFFE",
+            (isASCII) ? "\xef\xbf\xbe" : I8_to_native("\xf1\xbf\xbf\xbe"),
+            0xFFFE,
+        ],
+        [ "non-character code point U+FFFF",
+            (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
+            0xFFFF,
+        ],
+        [ "overlong malformation, lowest 4-byte",
+            (isASCII) ? "\xf0\x80\x80\x80" : I8_to_native("\xf0\xa0\xa0\xa0"),
+            0,   # NUL
+        ],
+        [ "overlong malformation, highest 4-byte",
+            (isASCII) ? "\xf0\x8F\xbf\xbf" : I8_to_native("\xf0\xaf\xbf\xbf"),
+            (isASCII) ? 0xFFFF : 0x3FFF,
+        ],
+        [ "non-character code point U+1FFFE",
+            (isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"),
+            0x1FFFE,
+        ],
+        [ "non-character code point U+1FFFF",
+            (isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"),
+            0x1FFFF,
+        ],
+        [ "non-character code point U+2FFFE",
+            (isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"),
+            0x2FFFE,
+        ],
+        [ "non-character code point U+2FFFF",
+            (isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"),
+            0x2FFFF,
+        ],
+        [ "non-character code point U+3FFFE",
+            (isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"),
+            0x3FFFE,
+        ],
+        [ "non-character code point U+3FFFF",
+            (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
+            0x3FFFF,
+        ],
+        [ "non-character code point U+4FFFE",
+            (isASCII)
+            ?               "\xf1\x8f\xbf\xbe"
+            : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
+            0x4FFFE,
+        ],
+        [ "non-character code point U+4FFFF",
+            (isASCII)
+            ?               "\xf1\x8f\xbf\xbf"
+            : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
+            0x4FFFF,
+        ],
+        [ "non-character code point U+5FFFE",
+            (isASCII)
+            ?              "\xf1\x9f\xbf\xbe"
+            : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
+            0x5FFFE,
+        ],
+        [ "non-character code point U+5FFFF",
+            (isASCII)
+            ?              "\xf1\x9f\xbf\xbf"
+            : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
+            0x5FFFF,
+        ],
+        [ "non-character code point U+6FFFE",
+            (isASCII)
+            ?              "\xf1\xaf\xbf\xbe"
+            : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
+            0x6FFFE,
+        ],
+        [ "non-character code point U+6FFFF",
+            (isASCII)
+            ?              "\xf1\xaf\xbf\xbf"
+            : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
+            0x6FFFF,
+        ],
+        [ "non-character code point U+7FFFE",
+            (isASCII)
+            ?              "\xf1\xbf\xbf\xbe"
+            : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
+            0x7FFFE,
+        ],
+        [ "non-character code point U+7FFFF",
+            (isASCII)
+            ?              "\xf1\xbf\xbf\xbf"
+            : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
+            0x7FFFF,
+        ],
+        [ "non-character code point U+8FFFE",
+            (isASCII)
+            ?              "\xf2\x8f\xbf\xbe"
+            : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
+            0x8FFFE,
+        ],
+        [ "non-character code point U+8FFFF",
+            (isASCII)
+            ?              "\xf2\x8f\xbf\xbf"
+            : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
+            0x8FFFF,
+        ],
+        [ "non-character code point U+9FFFE",
+            (isASCII)
+            ?              "\xf2\x9f\xbf\xbe"
+            : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
+            0x9FFFE,
+        ],
+        [ "non-character code point U+9FFFF",
+            (isASCII)
+            ?              "\xf2\x9f\xbf\xbf"
+            : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
+            0x9FFFF,
+        ],
+        [ "non-character code point U+AFFFE",
+            (isASCII)
+            ?              "\xf2\xaf\xbf\xbe"
+            : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
+            0xAFFFE,
+        ],
+        [ "non-character code point U+AFFFF",
+            (isASCII)
+            ?              "\xf2\xaf\xbf\xbf"
+            : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
+            0xAFFFF,
+        ],
+        [ "non-character code point U+BFFFE",
+            (isASCII)
+            ?              "\xf2\xbf\xbf\xbe"
+            : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
+            0xBFFFE,
+        ],
+        [ "non-character code point U+BFFFF",
+            (isASCII)
+            ?              "\xf2\xbf\xbf\xbf"
+            : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
+            0xBFFFF,
+        ],
+        [ "non-character code point U+CFFFE",
+            (isASCII)
+            ?              "\xf3\x8f\xbf\xbe"
+            : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
+            0xCFFFE,
+        ],
+        [ "non-character code point U+CFFFF",
+            (isASCII)
+            ?              "\xf3\x8f\xbf\xbf"
+            : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
+            0xCFFFF,
+        ],
+        [ "non-character code point U+DFFFE",
+            (isASCII)
+            ?              "\xf3\x9f\xbf\xbe"
+            : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
+            0xDFFFE,
+        ],
+        [ "non-character code point U+DFFFF",
+            (isASCII)
+            ?              "\xf3\x9f\xbf\xbf"
+            : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
+            0xDFFFF,
+        ],
+        [ "non-character code point U+EFFFE",
+            (isASCII)
+            ?              "\xf3\xaf\xbf\xbe"
+            : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
+            0xEFFFE,
+        ],
+        [ "non-character code point U+EFFFF",
+            (isASCII)
+            ?              "\xf3\xaf\xbf\xbf"
+            : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
+            0xEFFFF,
+        ],
+        [ "non-character code point U+FFFFE",
+            (isASCII)
+            ?              "\xf3\xbf\xbf\xbe"
+            : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
+            0xFFFFE,
+        ],
+        [ "non-character code point U+FFFFF",
+            (isASCII)
+            ?              "\xf3\xbf\xbf\xbf"
+            : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
+            0xFFFFF,
+        ],
+        [ "non-character code point U+10FFFE",
+            (isASCII)
+            ?              "\xf4\x8f\xbf\xbe"
+            : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
+            0x10FFFE,
+        ],
+        [ "non-character code point U+10FFFF",
+            (isASCII)
+            ?              "\xf4\x8f\xbf\xbf"
+            : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
+            0x10FFFF,
+        ],
+        [ "first non_unicode",
+            (isASCII)
+            ?              "\xf4\x90\x80\x80"
+            : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
+            0x110000,
+            2,
+        ],
+        [ "non_unicode whose first byte tells that",
+            (isASCII)
+            ?              "\xf5\x80\x80\x80"
+            : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
+            (isASCII) ? 0x140000 : 0x200000,
+            1,
+        ],
+        [ "overlong malformation, lowest 5-byte",
+            (isASCII)
+            ?              "\xf8\x80\x80\x80\x80"
+            : I8_to_native("\xf8\xa0\xa0\xa0\xa0"),
+            0,   # NUL
+        ],
+        [ "overlong malformation, highest 5-byte",
+            (isASCII)
+            ?              "\xf8\x87\xbf\xbf\xbf"
+            : I8_to_native("\xf8\xa7\xbf\xbf\xbf"),
+            (isASCII) ? 0x1FFFFF : 0x3FFFF,
+        ],
+        [ "overlong malformation, lowest 6-byte",
+            (isASCII)
+            ?              "\xfc\x80\x80\x80\x80\x80"
+            : I8_to_native("\xfc\xa0\xa0\xa0\xa0\xa0"),
+            0,   # NUL
+        ],
+        [ "overlong malformation, highest 6-byte",
+            (isASCII)
+            ?              "\xfc\x83\xbf\xbf\xbf\xbf"
+            : I8_to_native("\xfc\xa3\xbf\xbf\xbf\xbf"),
+            (isASCII) ? 0x3FFFFFF : 0x3FFFFF,
+        ],
+        [ "overlong malformation, lowest 7-byte",
+            (isASCII)
+            ?              "\xfe\x80\x80\x80\x80\x80\x80"
+            : I8_to_native("\xfe\xa0\xa0\xa0\xa0\xa0\xa0"),
+            0,   # NUL
+        ],
+        [ "overlong malformation, highest 7-byte",
+            (isASCII)
+            ?              "\xfe\x81\xbf\xbf\xbf\xbf\xbf"
+            : I8_to_native("\xfe\xa1\xbf\xbf\xbf\xbf\xbf"),
+            (isASCII) ? 0x7FFFFFFF : 0x3FFFFFF,
+        ],
+        [ "highest 31 bit code point",
+            (isASCII)
+            ?  "\xfd\xbf\xbf\xbf\xbf\xbf"
+            : I8_to_native(
+               "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf"),
+            0x7FFFFFFF,
+            1,
+        ],
+        [ "lowest 32 bit code point",
+            (isASCII)
+            ?  "\xfe\x82\x80\x80\x80\x80\x80"
+            : I8_to_native(
+                "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
+            ($::is64bit) ? 0x80000000 : -1,   # Overflows on 32-bit systems
+            1,
+        ],
+        # Used when UV_MAX is allowed as a code point
+        #[ "highest 32 bit code point",
+        #    (isASCII)
+        #    ?  "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
+        #    : I8_to_native(
+        #       "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
+        #    0xFFFFFFFF,
+        #],
+        #[ "Lowest 33 bit code point",
+        #    (isASCII)
+        #    ?  "\xfe\x84\x80\x80\x80\x80\x80"
+        #    : I8_to_native(
+        #        "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"),
+        #    ($::is64bit) ? 0x100000000 : 0x0,   # Overflows on 32-bit systems
+        #],
+    );
+
+    if (! $::is64bit) {
+        if (isASCII) {
+            push @tests,
+                [ "overlong malformation, but naively looks like overflow",
+                    "\xff\x80\x80\x80\x80\x80\x80\x81\xbf\xbf\xbf\xbf\xbf",
+                    0x7FFFFFFF,
+                ],
+                # Used when above IV_MAX are allowed.
+                #[ "overlong malformation, but naively looks like overflow",
+                #    "\xff\x80\x80\x80\x80\x80\x80\x83\xbf\xbf\xbf\xbf\xbf",
+                #    0xFFFFFFFF,
+                #],
+                [ "overflow that old algorithm failed to detect",
+                    "\xfe\x86\x80\x80\x80\x80\x80",
+                    -1,
+                ];
+        }
+    }
+
+    push @tests,
+        [ "overlong malformation, lowest max-byte",
+            (isASCII)
+             ?      "\xff\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80"
+             : I8_to_native(
+                    "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
+            0,   # NUL
+        ],
+        [ "overlong malformation, highest max-byte",
+            (isASCII)    # 2**36-1 on ASCII; 2**30-1 on EBCDIC
+             ?      "\xff\x80\x80\x80\x80\x80\x80\xbf\xbf\xbf\xbf\xbf\xbf"
+             : I8_to_native(
+                    "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xbf\xbf\xbf\xbf\xbf\xbf"),
+            (isASCII) ? (($::is64bit) ? 0xFFFFFFFFF : -1) : 0x3FFFFFFF,
+        ];
+
+    if (isASCII) {
+        push @tests,
+            [ "Lowest code point requiring 13 bytes to represent", # 2**36
+                "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
+                ($::is64bit) ? 0x1000000000 : -1,    # overflows on 32bit
+            ],
+    };
+
+    if ($::is64bit) {
+        push @tests,
+            [ "highest 63 bit code point",
+              (isASCII)
+              ? "\xff\x80\x87\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
+              : I8_to_native(
+                "\xff\xa7\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"),
+              0x7FFFFFFFFFFFFFFF,
+              (isASCII) ? 1 : 2,
+            ],
+            [ "first 64 bit code point",
+              (isASCII)
+              ? "\xff\x80\x88\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80"
+              : I8_to_native(
+                "\xff\xa8\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
+              -1,
+            ];
+            # Used when UV_MAX is allowed as a code point
+            #[ "highest 64 bit code point",
+            #  (isASCII)
+            #  ? "\xff\x80\x8f\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
+            #  : I8_to_native(
+            #    "\xff\xaf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"),
+            #  0xFFFFFFFFFFFFFFFF,
+            #  (isASCII) ? 1 : 2,
+            #],
+            #[ "first 65 bit code point",
+            #  (isASCII)
+            #  ? "\xff\x80\x9f\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80"
+            #  : I8_to_native(
+            #    "\xff\xb0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
+            #  0,
+            #];
+        if (isASCII) {
+            push @tests,
+                [ "overflow that old algorithm failed to detect",
+                    "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf",
+                    -1,
+                ];
+        }
+        else {
+            push @tests,    # These could falsely show wrongly in a naive
+                            # implementation
+                [ "requires at least 32 bits",
+                    I8_to_native(
+                    "\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
+                    0x800000000,
+                      40000000
+                ],
+                [ "requires at least 32 bits",
+                    I8_to_native(
+                    "\xff\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
+                    0x10000000000,
+                ],
+                [ "requires at least 32 bits",
+                    I8_to_native(
+                    "\xff\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
+                    0x200000000000,
+                ],
+                [ "requires at least 32 bits",
+                    I8_to_native(
+                    "\xff\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
+                    0x4000000000000,
+                ],
+                [ "requires at least 32 bits",
+                    I8_to_native(
+                    "\xff\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
+                    0x80000000000000,
+                ],
+                [ "requires at least 32 bits",
+                    I8_to_native(
+                    "\xff\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
+                    0x1000000000000000,
+                ];
+        }
+    }
+}
+
+sub flags_to_text($$)
+{
+    my ($flags, $flags_to_text_ref) = @_;
+
+    # Returns a string containing a mnemonic representation of the bits that
+    # are set in the $flags.  These are assumed to be flag bits.  The return
+    # looks like "FOO|BAR|BAZ".  The second parameter is a reference to an
+    # array that gives the textual representation of all the possible flags.
+    # Element 0 is the text for the bit 0 flag; element 1 for bit 1; ....  If
+    # no bits at all are set the string "0" is returned;
+
+    my @flag_text;
+    my $shift = 0;
+
+    return "0" if $flags == 0;
+
+    while ($flags) {
+        #diag sprintf "%x", $flags;
+        if ($flags & 1) {
+            push @flag_text, $flags_to_text_ref->[$shift];
+        }
+        $shift++;
+        $flags >>= 1;
+    }
+
+    return join "|", @flag_text;
+}
+
+# Possible flag returns from utf8n_to_uvchr_error().  These should have G_,
+# instead of A_, D_, but the prefixes will be used in a a later commit, so
+# minimize churn by having them here.
+my @utf8n_flags_to_text =  ( qw(
+        A_EMPTY
+        A_CONTINUATION
+        A_NON_CONTINUATION
+        A_SHORT
+        A_LONG
+        A_LONG_AND_ITS_VALUE
+        PLACEHOLDER
+        A_OVERFLOW
+        D_SURROGATE
+        W_SURROGATE
+        D_NONCHAR
+        W_NONCHAR
+        D_SUPER
+        W_SUPER
+        D_PERL_EXTENDED
+        W_PERL_EXTENDED
+        CHECK_ONLY
+        NO_CONFIDENCE_IN_CURLEN_
+    ) );
+
+sub utf8n_display_call($)
+{
+    # Converts an eval string that calls test_utf8n_to_uvchr into a more human
+    # readable form, and returns it.  Doesn't work if the byte string contains
+    # an apostrophe.  The return will look something like:
+    #   test_utf8n_to_uvchr_error('$bytes', $length, $flags)
+    #diag $_[0];
+
+    $_[0] =~ / ^ ( [^(]* \( ) ' ( [^']*? ) ' ( .+ , \D* ) ( \d+ ) \) $ /x;
+    my $text1 = $1;     # Everything before the byte string
+    my $bytes = $2;
+    my $text2 = $3;     # Includes the length
+    my $flags = $4;
+
+    return $text1
+         . display_bytes($bytes)
+         . $text2
+         . flags_to_text($flags, \@utf8n_flags_to_text)
+         . ')';
+}
+
+my @uvchr_flags_to_text =  ( qw(
+        W_SURROGATE
+        W_NONCHAR
+        W_SUPER
+        W_PERL_EXTENDED
+        D_SURROGATE
+        D_NONCHAR
+        D_SUPER
+        D_PERL_EXTENDED
+) );
+
+sub uvchr_display_call($)
+{
+    # Converts an eval string that calls test_uvchr_to_utf8 into a more human
+    # readable form, and returns it.  The return will look something like:
+    #   test_uvchr_to_utf8n_flags($uv, $flags)
+    #diag $_[0];
+
+
+    $_[0] =~ / ^ ( [^(]* \( ) ( \d+ ) , \s* ( \d+ ) \) $ /x;
+    my $text = $1;
+    my $cp = sprintf "%X", $2;
+    my $flags = $3;
+
+    return "${text}0x$cp, " . flags_to_text($flags, \@uvchr_flags_to_text) . ')';
+}
+
+sub do_warnings_test(@)
+{
+    my @expected_warnings = @_;
+
+    # Compares the input expected warnings array with @warnings_gotten,
+    # generating a pass for each found, removing it from @warnings_gotten.
+    # Any discrepancies generate test failures.  Returns TRUE if no
+    # discrepcancies; otherwise FALSE.
+
+    my $succeeded = 1;
+
+    if (@expected_warnings == 0) {
+        if (! is(@warnings_gotten, 0, "    Expected and got no warnings")) {
+            output_warnings(@warnings_gotten);
+            $succeeded = 0;
+        }
+        return $succeeded;
+    }
+
+    # Check that we got all the expected warnings,
+    # removing each one found
+  WARNING:
+    foreach my $expected (@expected_warnings) {
+        foreach (my $i = 0; $i < @warnings_gotten; $i++) {
+            if ($warnings_gotten[$i] =~ $expected) {
+                pass("    Expected and got warning: "
+                    . " $warnings_gotten[$i]");
+                splice @warnings_gotten, $i, 1;
+                next WARNING;
+            }
+        }
+        fail("    Expected a warning that matches "
+            . $expected . " but didn't get it");
+        $succeeded = 0;
+    }
+
+    if (! is(@warnings_gotten, 0, "    Got no unexpected warnings")) {
+        output_warnings(@warnings_gotten);
+        $succeeded = 0;
+    }
+
+    return $succeeded;
+}
+
+# This test is split into this number of files.
+my $num_test_files = $ENV{TEST_JOBS} || 1;
+$num_test_files = 10 if $num_test_files > 10;
+
+# We only really need to test utf8n_to_uvchr_msgs() once with this flag.
+my $tested_CHECK_ONLY = 0;
+
+my $test_count = -1;
+foreach my $test (@tests) {
+  $test_count++;
+  next if $test_count % $num_test_files != $::TEST_CHUNK;
+
+  my ($testname, $bytes, $allowed_uv, $needed_to_discern_len) = @$test;
+
+  my $length = length $bytes;
+  my $initially_overlong = $testname =~ /overlong/;
+  my $initially_orphan   = $testname =~ /orphan/;
+  my $will_overflow = $allowed_uv < 0;
+
+  my $uv_string = sprintf(($allowed_uv < 0x100) ? "%02X" : "%04X", $allowed_uv);
+  my $display_bytes = display_bytes($bytes);
+
+  my $controlling_warning_category;
+  my $utf8n_flag_to_warn;
+  my $utf8n_flag_to_disallow;
+  my $uvchr_flag_to_warn;
+  my $uvchr_flag_to_disallow;
+
+  # We want to test that the independent flags are actually independent.
+  # For example, that a surrogate doesn't trigger a non-character warning,
+  # and conversely, turning off an above-Unicode flag doesn't suppress a
+  # surrogate warning.  Earlier versions of this file used nested loops to
+  # test all possible combinations.  But that creates lots of tests, making
+  # this run too long.  What is now done instead is to use the complement of
+  # the category we are testing to greatly reduce the combinatorial
+  # explosion.  For example, if we have a surrogate and we aren't expecting
+  # a warning about it, we set all the flags for non-surrogates to raise
+  # warnings.  If one shows up, it indicates the flags aren't independent.
+  my $utf8n_flag_to_warn_complement;
+  my $utf8n_flag_to_disallow_complement;
+  my $uvchr_flag_to_warn_complement;
+  my $uvchr_flag_to_disallow_complement;
+
+  # Many of the code points being tested are middling in that if code point
+  # edge cases work, these are very likely to as well.  Because this test
+  # file takes a while to execute, we skip testing the edge effects of code
+  # points deemed middling, while testing their basics and continuing to
+  # fully test the non-middling code points.
+  my $skip_most_tests = 0;
+
+  my $cp_message_qr;      # Pattern that matches the message raised when
+                          # that message contains the problematic code
+                          # point.  The message is the same (currently) both
+                          # when going from/to utf8.
+  my $non_cp_trailing_text;   # The suffix text when the message doesn't
+                              # contain a code point.  (This is a result of
+                              # some sort of malformation that means we
+                              # can't get an exact code poin
+  my $extended_cp_message_qr = qr/\QCode point 0x$uv_string is not Unicode,\E
+                      \Q requires a Perl extension, and so is not\E
+                      \Q portable\E/x;
+  my $extended_non_cp_trailing_text
+                      = "is a Perl extension, and so is not portable";
+
+  # What bytes should have been used to specify a code point that has been
+  # specified as an overlong.
+  my $correct_bytes_for_overlong;
+
+  # Is this test malformed from the beginning?  If so, we know to generally
+  # expect that the tests will show it isn't valid.
+  my $initially_malformed = 0;
+
+  if ($initially_overlong || $initially_orphan) {
+      $non_cp_trailing_text = "if you see this, there is an error";
+      $cp_message_qr = qr/\Q$non_cp_trailing_text\E/;
+      $initially_malformed = 1;
+      $utf8n_flag_to_warn     = 0;
+      $utf8n_flag_to_disallow = 0;
+
+      $utf8n_flag_to_warn_complement =     $::UTF8_WARN_SURROGATE;
+      $utf8n_flag_to_disallow_complement = $::UTF8_DISALLOW_SURROGATE;
+      if (! $will_overflow && $allowed_uv <= 0x10FFFF) {
+          $utf8n_flag_to_warn_complement     |= $::UTF8_WARN_SUPER;
+          $utf8n_flag_to_disallow_complement |= $::UTF8_DISALLOW_SUPER;
+          if (($allowed_uv & 0xFFFF) != 0xFFFF) {
+              $utf8n_flag_to_warn_complement      |= $::UTF8_WARN_NONCHAR;
+              $utf8n_flag_to_disallow_complement  |= $::UTF8_DISALLOW_NONCHAR;
+          }
+      }
+      if (! is_extended_utf8($bytes)) {
+          $utf8n_flag_to_warn_complement |= $::UTF8_WARN_PERL_EXTENDED;
+          $utf8n_flag_to_disallow_complement  |= $::UTF8_DISALLOW_PERL_EXTENDED;
+      }
+
+      $controlling_warning_category = 'utf8';
+
+      if ($initially_overlong) {
+          if (! defined $needed_to_discern_len) {
+              $needed_to_discern_len = overlong_discern_len($bytes);
+          }
+          $correct_bytes_for_overlong = display_bytes_no_quotes(chr $allowed_uv);
+      }
+  }
+  elsif($will_overflow || $allowed_uv > 0x10FFFF) {
+
+      # Set the SUPER flags; later, we test for PERL_EXTENDED as well.
+      $utf8n_flag_to_warn     = $::UTF8_WARN_SUPER;
+      $utf8n_flag_to_disallow = $::UTF8_DISALLOW_SUPER;
+      $uvchr_flag_to_warn     = $::UNICODE_WARN_SUPER;
+      $uvchr_flag_to_disallow = $::UNICODE_DISALLOW_SUPER;;
+
+      # Below, we add the flags for non-perl_extended to the code points
+      # that don't fit that category.  Special tests are done for this
+      # category in the inner loop.
+      $utf8n_flag_to_warn_complement     = $::UTF8_WARN_NONCHAR
+                                          |$::UTF8_WARN_SURROGATE;
+      $utf8n_flag_to_disallow_complement = $::UTF8_DISALLOW_NONCHAR
+                                          |$::UTF8_DISALLOW_SURROGATE;
+      $uvchr_flag_to_warn_complement     = $::UNICODE_WARN_NONCHAR
+                                          |$::UNICODE_WARN_SURROGATE;
+      $uvchr_flag_to_disallow_complement = $::UNICODE_DISALLOW_NONCHAR
+                                          |$::UNICODE_DISALLOW_SURROGATE;
+      $controlling_warning_category = 'non_unicode';
+
+      if ($will_overflow) {  # This is realy a malformation
+          $non_cp_trailing_text = "if you see this, there is an error";
+          $cp_message_qr = qr/\Q$non_cp_trailing_text\E/;
+          $initially_malformed = 1;
+          if (! defined $needed_to_discern_len) {
+              $needed_to_discern_len = overflow_discern_len($length);
+          }
+      }
+      elsif (requires_extended_utf8($allowed_uv)) {
+          $cp_message_qr = $extended_cp_message_qr;
+          $non_cp_trailing_text = $extended_non_cp_trailing_text;
+          $needed_to_discern_len = 1 unless defined $needed_to_discern_len;
+      }
+      else {
+          $cp_message_qr = qr/\QCode point 0x$uv_string is not Unicode,\E
+                              \Q may not be portable\E/x;
+          $non_cp_trailing_text = "is for a non-Unicode code point, may not"
+                              . " be portable";
+          $utf8n_flag_to_warn_complement     |= $::UTF8_WARN_PERL_EXTENDED;
+          $utf8n_flag_to_disallow_complement
+                                          |= $::UTF8_DISALLOW_PERL_EXTENDED;
+          $uvchr_flag_to_warn_complement |= $::UNICODE_WARN_PERL_EXTENDED;
+          $uvchr_flag_to_disallow_complement
+                                      |= $::UNICODE_DISALLOW_PERL_EXTENDED;
+      }
+  }
+  elsif ($allowed_uv >= 0xD800 && $allowed_uv <= 0xDFFF) {
+      $cp_message_qr = qr/UTF-16 surrogate U\+$uv_string/;
+      $non_cp_trailing_text = "is for a surrogate";
+      $needed_to_discern_len = 2 unless defined $needed_to_discern_len;
+      $skip_most_tests = 1 if $allowed_uv > 0xD800 && $allowed_uv < 0xDFFF;
+
+      $utf8n_flag_to_warn     = $::UTF8_WARN_SURROGATE;
+      $utf8n_flag_to_disallow = $::UTF8_DISALLOW_SURROGATE;
+      $uvchr_flag_to_warn     = $::UNICODE_WARN_SURROGATE;
+      $uvchr_flag_to_disallow = $::UNICODE_DISALLOW_SURROGATE;;
+
+      $utf8n_flag_to_warn_complement     = $::UTF8_WARN_NONCHAR
+                                          |$::UTF8_WARN_SUPER
+                                          |$::UTF8_WARN_PERL_EXTENDED;
+      $utf8n_flag_to_disallow_complement = $::UTF8_DISALLOW_NONCHAR
+                                          |$::UTF8_DISALLOW_SUPER
+                                          |$::UTF8_DISALLOW_PERL_EXTENDED;
+      $uvchr_flag_to_warn_complement     = $::UNICODE_WARN_NONCHAR
+                                          |$::UNICODE_WARN_SUPER
+                                          |$::UNICODE_WARN_PERL_EXTENDED;
+      $uvchr_flag_to_disallow_complement = $::UNICODE_DISALLOW_NONCHAR
+                                          |$::UNICODE_DISALLOW_SUPER
+                                          |$::UNICODE_DISALLOW_PERL_EXTENDED;
+      $controlling_warning_category = 'surrogate';
+  }
+  elsif (   ($allowed_uv >= 0xFDD0 && $allowed_uv <= 0xFDEF)
+          || ($allowed_uv & 0xFFFE) == 0xFFFE)
+  {
+      $cp_message_qr = qr/\QUnicode non-character U+$uv_string\E
+                          \Q is not recommended for open interchange\E/x;
+      $non_cp_trailing_text = "if you see this, there is an error";
+      $needed_to_discern_len = $length unless defined $needed_to_discern_len;
+      if (   ($allowed_uv > 0xFDD0 && $allowed_uv < 0xFDEF)
+          || ($allowed_uv > 0xFFFF && $allowed_uv < 0x10FFFE))
+      {
+          $skip_most_tests = 1;
+      }
+
+      $utf8n_flag_to_warn     = $::UTF8_WARN_NONCHAR;
+      $utf8n_flag_to_disallow = $::UTF8_DISALLOW_NONCHAR;
+      $uvchr_flag_to_warn     = $::UNICODE_WARN_NONCHAR;
+      $uvchr_flag_to_disallow = $::UNICODE_DISALLOW_NONCHAR;;
+
+      $utf8n_flag_to_warn_complement     = $::UTF8_WARN_SURROGATE
+                                          |$::UTF8_WARN_SUPER
+                                          |$::UTF8_WARN_PERL_EXTENDED;
+      $utf8n_flag_to_disallow_complement = $::UTF8_DISALLOW_SURROGATE
+                                          |$::UTF8_DISALLOW_SUPER
+                                          |$::UTF8_DISALLOW_PERL_EXTENDED;
+      $uvchr_flag_to_warn_complement     = $::UNICODE_WARN_SURROGATE
+                                          |$::UNICODE_WARN_SUPER
+                                          |$::UNICODE_WARN_PERL_EXTENDED;
+      $uvchr_flag_to_disallow_complement = $::UNICODE_DISALLOW_SURROGATE
+                                          |$::UNICODE_DISALLOW_SUPER
+                                          |$::UNICODE_DISALLOW_PERL_EXTENDED;
+
+      $controlling_warning_category = 'nonchar';
+  }
+  else {
+      die "Can't figure out what type of warning to test for $testname"
+  }
+
+  die 'Didn\'t set $needed_to_discern_len for ' . $testname
+                                      unless defined $needed_to_discern_len;
+
+  # We try various combinations of malformations that can occur
+  foreach my $short (0, 1) {
+    next if $skip_most_tests && $short;
+    foreach my $unexpected_noncont (0, 1) {
+      next if $skip_most_tests && $unexpected_noncont;
+      foreach my $overlong (0, 1) {
+        next if $overlong && $skip_most_tests;
+        next if $initially_overlong && ! $overlong;
+
+        # If we're creating an overlong, it can't be longer than the
+        # maximum length, so skip if we're already at that length.
+        next if   (! $initially_overlong && $overlong)
+                  &&  $length >= $::max_bytes;
+
+        my $this_cp_message_qr = $cp_message_qr;
+        my $this_non_cp_trailing_text = $non_cp_trailing_text;
+
+        foreach my $malformed_allow_type (0..2) {
+          # 0 don't allow this malformation; ignored if no malformation
+          # 1 allow, with REPLACEMENT CHARACTER returned
+          # 2 allow, with intended code point returned.  All malformations
+          #   other than overlong can't determine the intended code point,
+          #   so this isn't valid for them.
+          next if     $malformed_allow_type == 2
+                  && ($will_overflow || $short || $unexpected_noncont);
+          next if $skip_most_tests && $malformed_allow_type;
+
+          # Here we are in the innermost loop for malformations.  So we
+          # know which ones are in effect.  Can now change the input to be
+          # appropriately malformed.  We also can set up certain other
+          # things now, like whether we expect a return flag from this
+          # malformation, and which flag.
+
+          my $this_bytes = $bytes;
+          my $this_length = $length;
+          my $this_expected_len = $length;
+          my $this_needed_to_discern_len = $needed_to_discern_len;
+
+          my @malformation_names;
+          my @expected_malformation_warnings;
+          my @expected_malformation_return_flags;
+
+          # Contains the flags for any allowed malformations.  Currently no
+          # combinations of on/off are tested for.  It's either all are
+          # allowed, or none are.
+          my $allow_flags = 0;
+          my $overlong_is_in_perl_extended_utf8 = 0;
+          my $dont_use_overlong_cp = 0;
+
+          if ($initially_orphan) {
+              next if $overlong || $short || $unexpected_noncont;
+          }
+
+          if ($overlong) {
+              if (! $initially_overlong) {
+                  my $new_expected_len;
+
+                  # To force this malformation, we convert the original start
+                  # byte into a continuation byte with the same data bits as
+                  # originally. ...
+                  my $start_byte = substr($this_bytes, 0, 1);
+                  my $converted_to_continuation_byte
+                                          = start_byte_to_cont($start_byte);
+
+                  # ... Then we prepend it with a known overlong sequence.
+                  # This should evaluate to the exact same code point as the
+                  # original.  We try to avoid an overlong using Perl
+                  # extended UTF-8.  The code points are the highest
+                  # representable as overlongs on the respective platform
+                  # without using extended UTF-8.
+                  if (native_to_I8($start_byte) lt "\xFC") {
+                      $start_byte = I8_to_native("\xFC");
+                      $new_expected_len = 6;
+                  }
+                  elsif (! isASCII && native_to_I8($start_byte) lt "\xFE") {
+
+                      # FE is not extended UTF-8 on EBCDIC
+                      $start_byte = I8_to_native("\xFE");
+                      $new_expected_len = 7;
+                  }
+                  else {  # Must use extended UTF-8.  On ASCII platforms, we
+                          # could express some overlongs here starting with
+                          # \xFE, but there's no real reason to do so.
+                      $overlong_is_in_perl_extended_utf8 = 1;
+                      $start_byte = I8_to_native("\xFF");
+                      $new_expected_len = $::max_bytes;
+                      $this_cp_message_qr = $extended_cp_message_qr;
+
+                      # The warning that gets raised doesn't include the
+                      # code point in the message if the code point can be
+                      # expressed without using extended UTF-8, but the
+                      # particular overlong sequence used is in extended
+                      # UTF-8.  To do otherwise would be confusing to the
+                      # user, as it would claim the code point requires
+                      # extended, when it doesn't.
+                      $dont_use_overlong_cp = 1
+                                  unless requires_extended_utf8($allowed_uv);
+                      $this_non_cp_trailing_text
+                                            = $extended_non_cp_trailing_text;
+                  }
+
+                  # Splice in the revise continuation byte, preceded by the
+                  # start byte and the proper number of the lowest
+                  # continuation bytes.
+                  $this_bytes =   $start_byte
+                              . ($native_lowest_continuation_chr
+                                  x (  $new_expected_len
+                                      - 1
+                                      - length($this_bytes)))
+                              .  $converted_to_continuation_byte
+                              .  substr($this_bytes, 1);
+                  $this_length = length($this_bytes);
+                  $this_needed_to_discern_len =    $new_expected_len
+                                              - (  $this_expected_len
+                                              - $this_needed_to_discern_len);
+                  $this_expected_len = $new_expected_len;
+              }
+          }
+
+          if ($short) {
+
+              # To force this malformation, just tell the test to not look
+              # as far as it should into the input.
+              $this_length--;
+              $this_expected_len--;
+
+              $allow_flags |= $::UTF8_ALLOW_SHORT if $malformed_allow_type;
+          }
+
+          if ($unexpected_noncont) {
+
+              # To force this malformation, change the final continuation
+              # byte into a start byte.
+              my $pos = ($short) ? -2 : -1;
+              substr($this_bytes, $pos, 1) = $known_start_byte;
+              $this_expected_len--;
+          }
+
+          # The whole point of a test that is malformed from the beginning
+          # is to test for that malformation.  If we've modified things so
+          # much that we don't have enough information to detect that
+          # malformation, there's no point in testing.
+          next if    $initially_malformed
+                  && $this_expected_len < $this_needed_to_discern_len;
+
+          # Here, we've transformed the input with all of the desired
+          # non-overflow malformations.  We are now in a position to
+          # construct any potential warnings for those malformations.  But
+          # it's a pain to get the detailed messages exactly right, so for
+          # now XXX, only do so for those that return an explicit code
+          # point.
+
+          if ($initially_orphan) {
+              push @malformation_names, "orphan continuation";
+              push @expected_malformation_return_flags,
+                                                  $::UTF8_GOT_CONTINUATION;
+              $allow_flags |= $::UTF8_ALLOW_CONTINUATION
+                                                  if $malformed_allow_type;
+              push @expected_malformation_warnings, qr/unexpected continuation/;
+          }
+
+          if ($overlong) {
+              push @malformation_names, 'overlong';
+              push @expected_malformation_return_flags, $::UTF8_GOT_LONG;
+
+              # If one of the other malformation types is also in effect, we
+              # don't know what the intended code point was.
+              if ($short || $unexpected_noncont || $will_overflow) {
+                  push @expected_malformation_warnings, qr/overlong/;
+              }
+              else {
+                  my $wrong_bytes = display_bytes_no_quotes(
+                                        substr($this_bytes, 0, $this_length));
+                  if (! defined $correct_bytes_for_overlong) {
+                      $correct_bytes_for_overlong
+                                          = display_bytes_no_quotes($bytes);
+                  }
+                  my $prefix = (   $allowed_uv > 0x10FFFF
+                                || ! isASCII && $allowed_uv < 256)
+                                ? "0x"
+                                : "U+";
+                  push @expected_malformation_warnings,
+                          qr/\QMalformed UTF-8 character: $wrong_bytes\E
+                              \Q (overlong; instead use\E
+                              \Q $correct_bytes_for_overlong to\E
+                              \Q represent $prefix$uv_string)/x;
+              }
+
+              if ($malformed_allow_type == 2) {
+                  $allow_flags |= $::UTF8_ALLOW_LONG_AND_ITS_VALUE;
+              }
+              elsif ($malformed_allow_type) {
+                  $allow_flags |= $::UTF8_ALLOW_LONG;
+              }
+          }
+          if ($short) {
+              push @malformation_names, 'short';
+              push @expected_malformation_return_flags, $::UTF8_GOT_SHORT;
+              push @expected_malformation_warnings, qr/too short/;
+          }
+          if ($unexpected_noncont) {
+              push @malformation_names, 'unexpected non-continuation';
+              push @expected_malformation_return_flags,
+                              $::UTF8_GOT_NON_CONTINUATION;
+              $allow_flags |= $::UTF8_ALLOW_NON_CONTINUATION
+                                                  if $malformed_allow_type;
+              push @expected_malformation_warnings,
+                                      qr/unexpected non-continuation byte/;
+          }
+
+          # The overflow malformation is done differently than other
+          # malformations.  It comes from manually typed tests in the test
+          # array.  We now make it be treated like one of the other
+          # malformations.  But some has to be deferred until the inner loop
+          my $overflow_msg_pattern;
+          if ($will_overflow) {
+              push @malformation_names, 'overflow';
+
+              $overflow_msg_pattern = display_bytes_no_quotes(
+                                  substr($this_bytes, 0, $this_expected_len));
+              $overflow_msg_pattern = qr/\QMalformed UTF-8 character:\E
+                                          \Q $overflow_msg_pattern\E
+                                          \Q (overflows)\E/x;
+              push @expected_malformation_return_flags, $::UTF8_GOT_OVERFLOW;
+              $allow_flags |= $::UTF8_ALLOW_OVERFLOW if $malformed_allow_type;
+          }
+
+          # And we can create the malformation-related text for the the test
+          # names we eventually will generate.
+          my $malformations_name = "";
+          if (@malformation_names) {
+              $malformations_name .= "dis" unless $malformed_allow_type;
+              $malformations_name .= "allowed ";
+              $malformations_name .= "malformation";
+              $malformations_name .= "s" if @malformation_names > 1;
+              $malformations_name .= ": ";
+              $malformations_name .=  join "/", @malformation_names;
+              $malformations_name =  " ($malformations_name)";
+          }
+
+          # Done setting up the malformation related stuff
+
+          {   # First test the isFOO calls
+              use warnings; # XXX no warnings 'deprecated';   # Make sure these don't raise warnings
+              undef @warnings_gotten;
+
+              my $ret = test_isUTF8_CHAR($this_bytes, $this_length);
+              my $ret_flags
+                      = test_isUTF8_CHAR_flags($this_bytes, $this_length, 0);
+              if ($malformations_name) {
+                  is($ret, 0, "For $testname$malformations_name: isUTF8_CHAR() returns 0");
+                  is($ret_flags, 0, "    And isUTF8_CHAR_flags() returns 0");
+              }
+              else {
+                  is($ret, $this_length, "For $testname: isUTF8_CHAR() returns"
+                                        . " expected length: $this_length");
+                  is($ret_flags, $this_length,
+                      "    And isUTF8_CHAR_flags(...,0) returns expected"
+                    . " length: $this_length");
+              }
+              is(scalar @warnings_gotten, 0,
+                  "    And neither isUTF8_CHAR() nor isUTF8_CHAR()_flags"
+                . " generated any warnings")
+              or output_warnings(@warnings_gotten);
+
+              undef @warnings_gotten;
+              $ret = test_isSTRICT_UTF8_CHAR($this_bytes, $this_length);
+              if ($malformations_name) {
+                  is($ret, 0, "    And isSTRICT_UTF8_CHAR() returns 0");
+              }
+              else {
+                  my $expected_ret
+                              = (   $testname =~ /surrogate|non-character/
+                                  || $allowed_uv > 0x10FFFF)
+                                ? 0
+                                : $this_length;
+                  is($ret, $expected_ret,
+                      "    And isSTRICT_UTF8_CHAR() returns expected"
+                    . " length: $expected_ret");
+                  $ret = test_isUTF8_CHAR_flags($this_bytes, $this_length,
+                                      $::UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
+                  is($ret, $expected_ret,
+                      "    And isUTF8_CHAR_flags('"
+                    . "DISALLOW_ILLEGAL_INTERCHANGE') acts like"
+                    . " isSTRICT_UTF8_CHAR");
+              }
+              is(scalar @warnings_gotten, 0,
+                      "    And neither isSTRICT_UTF8_CHAR() nor"
+                    . " isUTF8_CHAR_flags generated any warnings")
+              or output_warnings(@warnings_gotten);
+
+              undef @warnings_gotten;
+              $ret = test_isC9_STRICT_UTF8_CHAR($this_bytes, $this_length);
+              if ($malformations_name) {
+                  is($ret, 0, "    And isC9_STRICT_UTF8_CHAR() returns 0");
+              }
+              else {
+                  my $expected_ret = (   $testname =~ /surrogate/
+                                      || $allowed_uv > 0x10FFFF)
+                                      ? 0
+                                      : $this_expected_len;
+                  is($ret, $expected_ret, "    And isC9_STRICT_UTF8_CHAR()"
+                                        . " returns expected length:"
+                                        . " $expected_ret");
+                  $ret = test_isUTF8_CHAR_flags($this_bytes, $this_length,
+                                  $::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
+                  is($ret, $expected_ret,
+                      "    And isUTF8_CHAR_flags('"
+                    . "DISALLOW_ILLEGAL_C9_INTERCHANGE') acts like"
+                    . " isC9_STRICT_UTF8_CHAR");
+              }
+              is(scalar @warnings_gotten, 0,
+                      "    And neither isC9_STRICT_UTF8_CHAR() nor"
+                    . " isUTF8_CHAR_flags generated any warnings")
+              or output_warnings(@warnings_gotten);
+
+              foreach my $disallow_type (0..2) {
+                  # 0 is don't disallow this type of code point
+                  # 1 is do disallow
+                  # 2 is do disallow, but only code points requiring
+                  #   perl-extended-UTF8
+
+                  my $disallow_flags;
+                  my $expected_ret;
+
+                  if ($malformations_name) {
+
+                      # Malformations are by default disallowed, so testing
+                      # with $disallow_type equal to 0 is sufficicient.
+                      next if $disallow_type;
+
+                      $disallow_flags = 0;
+                      $expected_ret = 0;
+                  }
+                  elsif ($disallow_type == 1) {
+                      $disallow_flags = $utf8n_flag_to_disallow;
+                      $expected_ret = 0;
+                  }
+                  elsif ($disallow_type == 2) {
+                      next if ! requires_extended_utf8($allowed_uv);
+                      $disallow_flags = $::UTF8_DISALLOW_PERL_EXTENDED;
+                      $expected_ret = 0;
+                  }
+                  else {  # type is 0
+                      $disallow_flags = $utf8n_flag_to_disallow_complement;
+                      $expected_ret = $this_length;
+                  }
+
+                  $ret = test_isUTF8_CHAR_flags($this_bytes, $this_length,
+                                                $disallow_flags);
+                  is($ret, $expected_ret,
+                            "    And isUTF8_CHAR_flags($display_bytes,"
+                          . " $disallow_flags) returns $expected_ret")
+                    or diag "The flags mean "
+                          . flags_to_text($disallow_flags,
+                                          \@utf8n_flags_to_text);
+                  is(scalar @warnings_gotten, 0,
+                          "    And isUTF8_CHAR_flags(...) generated"
+                        . " no warnings")
+                    or output_warnings(@warnings_gotten);
+
+                  # Test partial character handling, for each byte not a
+                  # full character
+                  my $did_test_partial = 0;
+                  for (my $j = 1; $j < $this_length - 1; $j++) {
+                      $did_test_partial = 1;
+                      my $partial = substr($this_bytes, 0, $j);
+                      my $ret_should_be;
+                      my $comment;
+                      if ($disallow_type || $malformations_name) {
+                          $ret_should_be = 0;
+                          $comment = "disallowed";
+
+                          # The number of bytes required to tell if a
+                          # sequence has something wrong is the smallest of
+                          # all the things wrong with it.  We start with the
+                          # number for this type of code point, if that is
+                          # disallowed; or the whole length if not.  The
+                          # latter is what a couple of the malformations
+                          # require.
+                          my $needed_to_tell = ($disallow_type)
+                                                ? $this_needed_to_discern_len
+                                                : $this_expected_len;
+
+                          # Then we see if the malformations that are
+                          # detectable early in the string are present.
+                          if ($overlong) {
+                              my $dl = overlong_discern_len($this_bytes);
+                              $needed_to_tell = $dl if $dl < $needed_to_tell;
+                          }
+                          if ($will_overflow) {
+                              my $dl = overflow_discern_len($length);
+                              $needed_to_tell = $dl if $dl < $needed_to_tell;
+                          }
+
+                          if ($j < $needed_to_tell) {
+                              $ret_should_be = 1;
+                              $comment .= ", but need $needed_to_tell"
+                                        . " bytes to discern:";
+                          }
+                      }
+                      else {
+                          $ret_should_be = 1;
+                          $comment = "allowed";
+                      }
+
+                      undef @warnings_gotten;
+
+                      $ret = test_is_utf8_valid_partial_char_flags($partial,
+                                                      $j, $disallow_flags);
+                      is($ret, $ret_should_be,
+                          "    And is_utf8_valid_partial_char_flags("
+                          . display_bytes($partial)
+                          . ", $disallow_flags), $comment: returns"
+                          . " $ret_should_be")
+                      or diag "The flags mean "
+                      . flags_to_text($disallow_flags, \@utf8n_flags_to_text);
+                  }
+
+                  if ($did_test_partial) {
+                      is(scalar @warnings_gotten, 0,
+                          "    And is_utf8_valid_partial_char_flags()"
+                          . " generated no warnings for any of the lengths")
+                        or output_warnings(@warnings_gotten);
+                  }
+              }
+          }
+
+          # Now test the to/from UTF-8 calls.  There are several orthogonal
+          # variables involved.  We test most possible combinations
+
+          foreach my $do_disallow (0, 1) {
+            if ($do_disallow) {
+              next if $initially_overlong || $initially_orphan;
+            }
+            else {
+              next if $skip_most_tests;
+            }
+
+            # This tests four functions: utf8n_to_uvchr_error,
+            # utf8n_to_uvchr_msgs, uvchr_to_utf8_flags, and
+            # uvchr_to_utf8_msgs.  The first two are variants of each other,
+            # and the final two also form a pair.  We use a loop 'which_func'
+            # to determine which of each pair is being tested.  The main loop
+            # tests either the first and third, or the 2nd and fourth.
+            # which_func is sets whether we are expecting warnings or not in
+            # certain places.  The _msgs() version of the functions expects
+            # warnings even if lexical ones are turned off, so by making its
+            # which_func == 1, we can say we want warnings; whereas the other
+            # one with the value 0, doesn't get them.
+            for my $which_func (0, 1) {
+              my $utf8_func = ($which_func)
+                          ? 'utf8n_to_uvchr_msgs'
+                          : 'utf8n_to_uvchr_error';
+
+              # We classify the warnings into certain "interesting" types,
+              # described later
+              foreach my $warning_type (0..4) {
+                next if $skip_most_tests && $warning_type != 1;
+                foreach my $use_warn_flag (0, 1) {
+                    if ($use_warn_flag) {
+                        next if $initially_overlong || $initially_orphan;
+
+                        # Since foo_msgs() expects warnings even when lexical
+                        # ones are turned off, we can skip testing it when
+                        # they are turned on, with little likelihood of
+                        # missing an error case.
+                        next if $which_func;
+                    }
+                    else {
+                        next if $skip_most_tests;
+                    }
+
+                    # Finally, here is the inner loop
+
+                    my $this_utf8n_flag_to_warn = $utf8n_flag_to_warn;
+                    my $this_utf8n_flag_to_disallow = $utf8n_flag_to_disallow;
+                    my $this_uvchr_flag_to_warn = $uvchr_flag_to_warn;
+                    my $this_uvchr_flag_to_disallow = $uvchr_flag_to_disallow;
+
+                    my $eval_warn;
+                    my $expect_regular_warnings;
+                    my $expect_warnings_for_malformed;
+                    my $expect_warnings_for_overflow;
+
+                    if ($warning_type == 0) {
+                        $eval_warn = "use warnings";
+                        $expect_regular_warnings = $use_warn_flag;
+
+                        # We ordinarily expect overflow warnings here.  But it
+                        # is somewhat more complicated, and the final
+                        # determination is deferred to one place in the file
+                        # where we handle overflow.
+                        $expect_warnings_for_overflow = 1;
+
+                        # We would ordinarily expect malformed warnings in
+                        # this case, but not if malformations are allowed.
+                        $expect_warnings_for_malformed
+                                                = $malformed_allow_type == 0;
+                    }
+                    elsif ($warning_type == 1) {
+                        $eval_warn = "no warnings";
+                        $expect_regular_warnings = $which_func;
+                        $expect_warnings_for_overflow = $which_func;
+                        $expect_warnings_for_malformed = $which_func;
+                    }
+                    elsif ($warning_type == 2) {
+                        $eval_warn = "no warnings; use warnings 'utf8'";
+                        $expect_regular_warnings = $use_warn_flag;
+                        $expect_warnings_for_overflow = 1;
+                        $expect_warnings_for_malformed
+                                                = $malformed_allow_type == 0;
+                    }
+                    elsif ($warning_type == 3) {
+                        $eval_warn = "no warnings; use warnings"
+                                   . " '$controlling_warning_category'";
+                        $expect_regular_warnings = $use_warn_flag;
+                        $expect_warnings_for_overflow
+                            = $controlling_warning_category eq 'non_unicode';
+                        $expect_warnings_for_malformed = $which_func;
+                    }
+                    elsif ($warning_type == 4) {  # Like type 3, but uses the
+                                                  # PERL_EXTENDED flags
+                        # The complement flags were set up so that the
+                        # PERL_EXTENDED flags have been tested that they don't
+                        # trigger wrongly for too small code points.  And the
+                        # flags have been set up so that those small code
+                        # points are tested for being above Unicode.  What's
+                        # left to test is that the large code points do
+                        # trigger the PERL_EXTENDED flags.
+                        next if ! requires_extended_utf8($allowed_uv);
+                        next if $controlling_warning_category ne 'non_unicode';
+                        $eval_warn = "no warnings; use warnings 'non_unicode'";
+                        $expect_regular_warnings = 1;
+                        $expect_warnings_for_overflow = 1;
+                        $expect_warnings_for_malformed = 0;
+                        $this_utf8n_flag_to_warn = $::UTF8_WARN_PERL_EXTENDED;
+                        $this_utf8n_flag_to_disallow
+                                             = $::UTF8_DISALLOW_PERL_EXTENDED;
+                        $this_uvchr_flag_to_warn
+                                              = $::UNICODE_WARN_PERL_EXTENDED;
+                        $this_uvchr_flag_to_disallow
+                                          = $::UNICODE_DISALLOW_PERL_EXTENDED;
+                    }
+                    else {
+                       die "Unexpected warning type '$warning_type'";
+                    }
+
+                    # We only need to test the case where all warnings are
+                    # enabled (type 0) to see if turning off the warning flag
+                    # causes things to not be output.  If those pass, then
+                    # turning on some sub-category of warnings, or turning off
+                    # warnings altogether are extremely likely to not output
+                    # warnings either, given how the warnings subsystem is
+                    # supposed to work, and this file assumes it does work.
+                    next if $warning_type != 0 && ! $use_warn_flag;
+
+                    # The convention is that the 'got' flag is the same value
+                    # as the disallow one.  If this were violated, the tests
+                    # here should start failing.
+                    my $return_flag = $this_utf8n_flag_to_disallow;
+
+                    # If we aren't expecting warnings/disallow for this, turn
+                    # on all the other flags.  That makes sure that they all
+                    # are independent of this flag, and so we don't need to
+                    # test them individually.
+                    my $this_warning_flags
+                            = ($use_warn_flag)
+                              ? $this_utf8n_flag_to_warn
+                              : ($overlong_is_in_perl_extended_utf8
+                                ? ($utf8n_flag_to_warn_complement
+                                    & ~$::UTF8_WARN_PERL_EXTENDED)
+                                :  $utf8n_flag_to_warn_complement);
+                    my $this_disallow_flags
+                            = ($do_disallow)
+                              ? $this_utf8n_flag_to_disallow
+                              : ($overlong_is_in_perl_extended_utf8
+                                 ? ($utf8n_flag_to_disallow_complement
+                                    & ~$::UTF8_DISALLOW_PERL_EXTENDED)
+                                 :  $utf8n_flag_to_disallow_complement);
+                    my $expected_uv = $allowed_uv;
+                    my $this_uv_string = $uv_string;
+
+                    my @expected_return_flags
+                                        = @expected_malformation_return_flags;
+                    my @expected_warnings;
+                    push @expected_warnings, @expected_malformation_warnings
+                                            if $expect_warnings_for_malformed;
+
+                    # The overflow malformation is done differently than other
+                    # malformations.  It comes from manually typed tests in
+                    # the test array, but it also is above Unicode and uses
+                    # Perl extended UTF-8, so affects some of the flags being
+                    # tested.  We now make it be treated like one of the other
+                    # generated malformations.
+                    if ($will_overflow) {
+
+                        # An overflow is (way) above Unicode, and overrides
+                        # everything else.
+                        $expect_regular_warnings = 0;
+
+                        # Earlier, we tentatively calculated whether this
+                        # should emit a message or not.  It's tentative
+                        # because, even if we ordinarily would output it, we
+                        # don't if malformations are allowed -- except an
+                        # overflow is also a SUPER and PERL_EXTENDED, and if
+                        # warnings for those are enabled, the overflow
+                        # warning does get raised.
+                        if (   $expect_warnings_for_overflow
+                            && (    $malformed_allow_type == 0
+                                ||   (   $this_warning_flags
+                                      & ($::UTF8_WARN_SUPER
+                                        |$::UTF8_WARN_PERL_EXTENDED))))
+                        {
+                            push @expected_warnings, $overflow_msg_pattern;
+                        }
+                    }
+
+                    # It may be that the malformations have shortened the
+                    # amount of input we look at so much that we can't tell
+                    # what the category the code point was in.  Otherwise, set
+                    # up the expected return flags based on the warnings and
+                    # disallowments.
+                    if ($this_expected_len < $this_needed_to_discern_len) {
+                        $expect_regular_warnings = 0;
+                    }
+                    elsif (   ($this_warning_flags & $this_utf8n_flag_to_warn)
+                           || (  $this_disallow_flags
+                               & $this_utf8n_flag_to_disallow))
+                    {
+                        push @expected_return_flags, $return_flag;
+                    }
+
+                    # Finish setting up the expected warning.
+                    if ($expect_regular_warnings) {
+
+                        # So far the array contains warnings generated by
+                        # malformations.  Add the expected regular one.
+                        unshift @expected_warnings, $this_cp_message_qr;
+
+                        # But it may need to be modified, because either of
+                        # these malformations means we can't determine the
+                        # expected code point.
+                        if (   $short || $unexpected_noncont
+                            || $dont_use_overlong_cp)
+                        {
+                            my $first_byte = substr($this_bytes, 0, 1);
+                            $expected_warnings[0] = display_bytes(
+                                    substr($this_bytes, 0, $this_expected_len));
+                            $expected_warnings[0]
+                                = qr/[Aa]\Qny UTF-8 sequence that starts with\E
+                                     \Q $expected_warnings[0]\E
+                                     \Q $this_non_cp_trailing_text\E/x;
+                        }
+                    }
+
+                    # Is effectively disallowed if we've set up a malformation
+                    # (unless malformations are allowed), even if the flag
+                    # indicates it is allowed.  Fix up test name to indicate
+                    # this as well
+                    my $disallowed = 0;
+                    if (   $this_disallow_flags & $this_utf8n_flag_to_disallow
+                        && $this_expected_len >= $this_needed_to_discern_len)
+                    {
+                        $disallowed = 1;
+                    }
+                    if ($malformations_name) {
+                        if ($malformed_allow_type == 0) {
+                            $disallowed = 1;
+                        }
+                        elsif ($malformed_allow_type == 1) {
+
+                            # Even if allowed, the malformation returns the
+                            # REPLACEMENT CHARACTER.
+                            $expected_uv = 0xFFFD;
+                            $this_uv_string = "0xFFFD"
+                        }
+                    }
+
+                    my $this_name = "$utf8_func() $testname: ";
+                    my @scratch_expected_return_flags = @expected_return_flags;
+                    if (! $initially_malformed) {
+                        $this_name .= ($disallowed)
+                                       ? 'disallowed, '
+                                       : 'allowed, ';
+                    }
+                    $this_name .= "$eval_warn";
+                    $this_name .= ", " . ((  $this_warning_flags
+                                            & $this_utf8n_flag_to_warn)
+                                          ? 'with flag for raising warnings'
+                                          : 'no flag for raising warnings');
+                    $this_name .= $malformations_name;
+
+                    # Do the actual test using an eval
+                    undef @warnings_gotten;
+                    my $ret_ref;
+                    my $this_flags
+                        = $allow_flags|$this_warning_flags|$this_disallow_flags;
+                    my $eval_text =      "$eval_warn; \$ret_ref"
+                            . " = test_$utf8_func("
+                            . "'$this_bytes', $this_length, $this_flags)";
+                    eval "$eval_text";
+                    if (! ok ($@ eq "", "$this_name: eval succeeded"))
+                    {
+                        diag "\$@='$@'; call was: "
+                           . utf8n_display_call($eval_text);
+                        next;
+                    }
+
+                    if ($disallowed) {
+                        is($ret_ref->[0], 0, "    And returns 0")
+                          or diag "Call was: " . utf8n_display_call($eval_text);
+                    }
+                    else {
+                        is($ret_ref->[0], $expected_uv,
+                                "    And returns expected uv: "
+                              . $this_uv_string)
+                          or diag "Call was: " . utf8n_display_call($eval_text);
+                    }
+                    is($ret_ref->[1], $this_expected_len,
+                                        "    And returns expected length:"
+                                      . " $this_expected_len")
+                      or diag "Call was: " . utf8n_display_call($eval_text);
+
+                    my $returned_flags = $ret_ref->[2];
+
+                    for (my $i = @scratch_expected_return_flags - 1;
+                         $i >= 0;
+                         $i--)
+                    {
+                      if ($scratch_expected_return_flags[$i] & $returned_flags)
+                      {
+                          if ($scratch_expected_return_flags[$i]
+                                              == $::UTF8_GOT_PERL_EXTENDED)
+                          {
+                              pass("    Expected and got return flag for"
+                                  . " PERL_EXTENDED");
+                          }
+                                  # The first entries in this are
+                                  # malformations
+                          elsif ($i > @malformation_names - 1)  {
+                              pass("    Expected and got return flag"
+                                  . " for " . $controlling_warning_category);
+                          }
+                          else {
+                              pass("    Expected and got return flag for "
+                                  . $malformation_names[$i]
+                                  . " malformation");
+                          }
+                          $returned_flags
+                                      &= ~$scratch_expected_return_flags[$i];
+                          splice @scratch_expected_return_flags, $i, 1;
+                      }
+                    }
+
+                    if (! is($returned_flags, 0,
+                       "    Got no unexpected return flags"))
+                    {
+                        diag "The unexpected flags gotten were: "
+                           . (flags_to_text($returned_flags,
+                                            \@utf8n_flags_to_text)
+                                # We strip off any prefixes from the flag
+                                # names
+                             =~ s/ \b [A-Z] _ //xgr);
+                        diag "Call was: " . utf8n_display_call($eval_text);
+                    }
+
+                    if (! is (scalar @scratch_expected_return_flags, 0,
+                        "    Got all expected return flags"))
+                    {
+                        diag "The expected flags not gotten were: "
+                           . (flags_to_text(eval join("|",
+                                                @scratch_expected_return_flags),
+                                            \@utf8n_flags_to_text)
+                                # We strip off any prefixes from the flag
+                                # names
+                             =~ s/ \b [A-Z] _ //xgr);
+                        diag "Call was: " . utf8n_display_call($eval_text);
+                    }
+
+                    if ($which_func) {
+                        my @returned_warnings;
+                        for my $element_ref (@{$ret_ref->[3]}) {
+                            push @returned_warnings, $element_ref->{'text'};
+                            my $text = $element_ref->{'text'};
+                            my $flag = $element_ref->{'flag_bit'};
+                            my $category = $element_ref->{'warning_category'};
+
+                            if (! ok(($flag & ($flag-1)) == 0,
+                                      "flag for returned msg is a single bit"))
+                            {
+                              diag sprintf("flags are %x; msg=%s", $flag, $text);
+                            }
+                            else {
+                              if (grep { $_ == $flag } @expected_return_flags) {
+                                  pass("flag for returned msg is expected");
+                              }
+                              else {
+                                  fail("flag ("
+                                     . flags_to_text($flag, \@utf8n_flags_to_text)
+                                     . ") for returned msg is expected");
+                              }
+                            }
+
+                            # In perl space, don't know the category numbers
+                            isnt($category, 0,
+                                          "returned category for msg isn't 0");
+                        }
+
+                        ok(@warnings_gotten == 0, "$utf8_func raised no warnings;"
+                              . " the next tests are for ones in the returned"
+                              . " variable")
+                            or diag join "\n", "The unexpected warnings were:",
+                                                              @warnings_gotten;
+                        @warnings_gotten = @returned_warnings;
+                    }
+
+                    do_warnings_test(@expected_warnings)
+                      or diag "Call was: " . utf8n_display_call($eval_text);
+                    undef @warnings_gotten;
+
+                    # Check CHECK_ONLY results when the input is
+                    # disallowed.  Do this when actually disallowed,
+                    # not just when the $this_disallow_flags is set.  We only
+                    # test once utf8n_to_uvchr_msgs() with this.
+                    if (   $disallowed
+                        && ($which_func == 0 || ! $tested_CHECK_ONLY))
+                    {
+                        $tested_CHECK_ONLY = 1;
+                        my $this_flags = $this_disallow_flags|$::UTF8_CHECK_ONLY;
+                        my $eval_text = "use warnings; \$ret_ref ="
+                                      . " test_$utf8_func('"
+                                      . "$this_bytes', $this_length,"
+                                      . " $this_flags)";
+                        eval $eval_text;
+                        if (! ok ($@ eq "",
+                            "    And eval succeeded with CHECK_ONLY"))
+                        {
+                            diag "\$@='$@'; Call was: "
+                               . utf8n_display_call($eval_text);
+                            next;
+                        }
+                        is($ret_ref->[0], 0, "    CHECK_ONLY: Returns 0")
+                          or diag "Call was: " . utf8n_display_call($eval_text);
+                        is($ret_ref->[1], -1,
+                                       "    CHECK_ONLY: returns -1 for length")
+                          or diag "Call was: " . utf8n_display_call($eval_text);
+                        if (! is(scalar @warnings_gotten, 0,
+                                      "    CHECK_ONLY: no warnings generated"))
+                        {
+                            diag "Call was: " . utf8n_display_call($eval_text);
+                            output_warnings(@warnings_gotten);
+                        }
+                    }
+
+                    # Now repeat some of the above, but for
+                    # uvchr_to_utf8_flags().  Since this comes from an
+                    # existing code point, it hasn't overflowed, and isn't
+                    # malformed.
+                    next if @malformation_names;
+
+                    my $uvchr_func = ($which_func)
+                                     ? 'uvchr_to_utf8_flags_msgs'
+                                     : 'uvchr_to_utf8_flags';
+
+                    $this_warning_flags = ($use_warn_flag)
+                                          ? $this_uvchr_flag_to_warn
+                                          : 0;
+                    $this_disallow_flags = ($do_disallow)
+                                           ? $this_uvchr_flag_to_disallow
+                                           : 0;
+
+                    $disallowed = $this_disallow_flags
+                                & $this_uvchr_flag_to_disallow;
+                    $this_name .= ", " . ((  $this_warning_flags
+                                           & $this_utf8n_flag_to_warn)
+                                          ? 'with flag for raising warnings'
+                                          : 'no flag for raising warnings');
+
+                    $this_name = "$uvchr_func() $testname: "
+                                        . (($disallowed)
+                                           ? 'disallowed'
+                                           : 'allowed');
+                    $this_name .= ", $eval_warn";
+                    $this_name .= ", " . ((  $this_warning_flags
+                                           & $this_uvchr_flag_to_warn)
+                                        ? 'with warning flag'
+                                        : 'no warning flag');
+
+                    undef @warnings_gotten;
+                    my $ret;
+                    $this_flags = $this_warning_flags|$this_disallow_flags;
+                    $eval_text = "$eval_warn; \$ret ="
+                            . " test_$uvchr_func("
+                            . "$allowed_uv, $this_flags)";
+                    eval "$eval_text";
+                    if (! ok ($@ eq "", "$this_name: eval succeeded"))
+                    {
+                        diag "\$@='$@'; call was: "
+                           . uvchr_display_call($eval_text);
+                        next;
+                    }
+
+                    if ($which_func) {
+                        if (defined $ret->[1]) {
+                            my @returned_warnings;
+                            push @returned_warnings, $ret->[1]{'text'};
+                            my $text = $ret->[1]{'text'};
+                            my $flag = $ret->[1]{'flag_bit'};
+                            my $category = $ret->[1]{'warning_category'};
+
+                            if (! ok(($flag & ($flag-1)) == 0,
+                                        "flag for returned msg is a single bit"))
+                            {
+                                diag sprintf("flags are %x; msg=%s", $flag, $text);
+                            }
+                            else {
+                                if ($flag & $this_uvchr_flag_to_disallow) {
+                                    pass("flag for returned msg is expected");
+                                }
+                                else {
+                                    fail("flag ("
+                                        . flags_to_text($flag, \@utf8n_flags_to_text)
+                                        . ") for returned msg is expected");
+                                }
+                            }
+
+                            # In perl space, don't know the category numbers
+                            isnt($category, 0,
+                                            "returned category for msg isn't 0");
+
+                            ok(@warnings_gotten == 0, "$uvchr_func raised no warnings;"
+                                . " the next tests are for ones in the returned"
+                                . " variable")
+                                or diag join "\n", "The unexpected warnings were:",
+                                                                @warnings_gotten;
+                            @warnings_gotten = @returned_warnings;
+                        }
+
+                        $ret = $ret->[0];
+                    }
+
+                    if ($disallowed) {
+                        is($ret, undef, "    And returns undef")
+                          or diag "Call was: " . uvchr_display_call($eval_text);
+                    }
+                    else {
+                        is($ret, $this_bytes, "    And returns expected string")
+                          or diag "Call was: " . uvchr_display_call($eval_text);
+                    }
+
+                    do_warnings_test(@expected_warnings)
+                      or diag "Call was: " . uvchr_display_call($eval_text);
+                }
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+}
+
+done_testing;
diff --git a/gnu/usr.bin/perl/ext/arybase/t/scope.t b/gnu/usr.bin/perl/ext/arybase/t/scope.t
index 07b41769779..5fca19610c3 100644
--- a/gnu/usr.bin/perl/ext/arybase/t/scope.t
+++ b/gnu/usr.bin/perl/ext/arybase/t/scope.t
@@ -30,6 +30,7 @@ is $t[3], "a";
 	is $t[3], "e";
 }
 is $t[3], "a";
+BEGIN { push @INC, '.' }
 use t::scope_0;
 is scope0_test(), "d";