This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
APItest/t/utf8_warn_base.pl: Revamp loop to/from utf8
authorKarl Williamson <khw@cpan.org>
Sun, 2 Jul 2017 15:11:17 +0000 (09:11 -0600)
committerKarl Williamson <khw@cpan.org>
Thu, 13 Jul 2017 03:14:24 +0000 (21:14 -0600)
This test file had gotten kinda messy as new tasks were shoe horned into
it.  This cleans it up, and positions it to be easier maintain going
forward.  I tried to minimize the number of changes shown per commit,
but this is the minimal I could get, and since it is a revamp, there are
lots of differences.

Some combinatorial explosion has been removed.

A new subroutine is created which compares the expected vs actually
gotten warnings, and is called in two places, removing duplicated code.

This exposed a bug in very large, hence rare, code points.  It will be
fixed in the next commit.  It was far easier to just make all similar
tests TODO here, removing that in the next commit.  This means this
commit has many passing TODOs

ext/XS-APItest/t/utf8_warn_base.pl

index 36c7058..2f5fc46 100644 (file)
@@ -210,7 +210,7 @@ my @tests = (
             "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
         # This code point is chosen so that it is representable in a UV on
         # 32-bit machines
-        'utf8', 0x80000000,
+        'non_unicode', 0x80000000,
         (isASCII) ? 1 : 8,
     ],
     [ "highest 32 bit code point",
@@ -218,7 +218,7 @@ my @tests = (
          ?  "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
          : I8_to_native(
             "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
-        'utf8', 0xFFFFFFFF,
+        'non_unicode', 0xFFFFFFFF,
         (isASCII) ? 1 : 8,
     ],
     [ "requires at least 32 bits, and use SUPER-type flags, instead of"
@@ -227,7 +227,7 @@ my @tests = (
          ? "\xfe\x82\x80\x80\x80\x80\x80"
          : I8_to_native(
            "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
-        'utf8', 0x80000000,
+        'non_unicode', 0x80000000,
         1,
     ],
     [ "overflow with warnings/disallow for more than 31 bits",
@@ -248,7 +248,7 @@ my @tests = (
            ?    "\xfe\x86\x80\x80\x80\x80\x80"
            : I8_to_native(
                 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))),
-        'utf8', -1,
+        'non_unicode', -1,
         (isASCII || $::is64bit) ? 2 : 8,
     ],
 );
@@ -259,7 +259,7 @@ if (! $::is64bit) {
         push @tests,
             [ "Lowest 33 bit code point: overflow",
                 "\xFE\x84\x80\x80\x80\x80\x80",
-                'utf8', -1,
+                'non_unicode', -1,
                 1,
             ];
     }
@@ -272,7 +272,7 @@ else {
             ?       "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
             : I8_to_native(
                     "\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
-            'utf8', 0x1000000000,
+            'non_unicode', 0x1000000000,
             (isASCII) ? 1 : 7,
         ];
     if (! isASCII) {
@@ -281,37 +281,37 @@ else {
             [ "requires at least 32 bits",
                 I8_to_native(
                     "\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
-                'utf8', 0x800000000,
+                'non_unicode', 0x800000000,
                 7,
             ],
             [ "requires at least 32 bits",
                 I8_to_native(
                     "\xff\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
-                'utf8', 0x10000000000,
+                'non_unicode', 0x10000000000,
                 6,
             ],
             [ "requires at least 32 bits",
                 I8_to_native(
                     "\xff\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
-                'utf8', 0x200000000000,
+                'non_unicode', 0x200000000000,
                 5,
             ],
             [ "requires at least 32 bits",
                 I8_to_native(
                     "\xff\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
-                'utf8', 0x4000000000000,
+                'non_unicode', 0x4000000000000,
                 4,
             ],
             [ "requires at least 32 bits",
                 I8_to_native(
                     "\xff\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
-                'utf8', 0x80000000000000,
+                'non_unicode', 0x80000000000000,
                 3,
             ],
             [ "requires at least 32 bits",
                 I8_to_native(
                     "\xff\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
-                'utf8', 0x1000000000000000,
+                'non_unicode', 0x1000000000000000,
                 2,
             ];
     }
@@ -416,6 +416,50 @@ sub uvchr_display_call($)
     return "${text}0x$cp, " . flags_to_text($flags, \@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;
@@ -463,7 +507,7 @@ foreach my $test (@tests) {
         $uvchr_flag_to_disallow = $::UNICODE_DISALLOW_SUPER;;
 
         if ($will_overflow) {
-            $non_cp_trailing_text = "overflows";
+            $non_cp_trailing_text = "if you see this, there is an error";
             $cp_message_qr = qr/\Q$non_cp_trailing_text\E/;
         }
         elsif ($allowed_uv > 0x7FFFFFFF) {
@@ -513,15 +557,6 @@ foreach my $test (@tests) {
 
     die 'Didn\'t set $needed_to_discern_len for ' . $testname
                                         unless defined $needed_to_discern_len;
-    my $disallow_flags = $utf8n_flag_to_disallow;
-    my $warn_flags = $disallow_flags << 1;
-
-    # The convention is that the got flag is the same value as the disallow
-    # one, and the warn flag is the next bit over.  If this were violated, the
-    # tests here should start failing.  We could do an eval under no strict to
-    # be sure.
-    my $expected_error_flags = $disallow_flags;
-
     {
         use warnings;
         undef @warnings_gotten;
@@ -597,7 +632,7 @@ foreach my $test (@tests) {
             # sufficient
             last if $will_overflow;
 
-            foreach my $disallow_flag (0, $disallow_flags) {
+            foreach my $disallow_flag (0, $utf8n_flag_to_disallow) {
                 my $partial = substr($bytes, 0, $j);
                 my $ret_should_be;
                 my $comment;
@@ -631,18 +666,13 @@ foreach my $test (@tests) {
         }
     }
 
-    # This is more complicated than the malformations tested earlier, as there
-    # are several orthogonal variables involved.  We test all the subclasses
-    # of utf8 warnings to verify they work with and without the utf8 class,
-    # and don't have effects on other sublass warnings
-    foreach my $trial_warning_category ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
+    # This is more complicated than the malformations tested in other files in
+    # this directory, as there are several orthogonal variables involved.  We
+    # test most possible combinations
+    foreach my $trial_warning_category ('surrogate', 'nonchar', 'non_unicode') {
       next if $skip_most_tests && $trial_warning_category ne $controlling_warning_category;
-      foreach my $warn_flag (0, $warn_flags) {
-        next if $skip_most_tests && ! $warn_flag;
-        foreach my $disallow_flag (0, $disallow_flags) {
-          next if $skip_most_tests && ! $disallow_flag;
-          foreach my $do_warning (0, 1) {
-            next if $skip_most_tests && ! $do_warning;
+      foreach my $do_disallow (0, 1) {
+        next if $skip_most_tests && ! $do_disallow;
 
             # We try each of the above with various combinations of
             # malformations that can occur on the same input sequence.
@@ -660,45 +690,112 @@ foreach my $test (@tests) {
                     # length.
                     next if $overlong && $length >= $::max_bytes;
 
-                    my @malformations;
-                    my @expected_return_flags;
-                    push @malformations, $short if $short;
-                    push @malformations, $unexpected_noncont
-                                                      if $unexpected_noncont;
-                    push @malformations, $overlong if $overlong;
-
-                    # The overflow malformation test in the input
-                    # array is coerced into being treated like one of
-                    # the others.
-                    if ($will_overflow) {
-                        push @malformations, 'overflow';
-                        push @expected_return_flags, $::UTF8_GOT_OVERFLOW;
+              # 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) {
+                    next if $skip_most_tests && ! $use_warn_flag;
+
+                    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; no warnings 'deprecated'";
+                        $expect_regular_warnings = $use_warn_flag;
+                        $expect_warnings_for_overflow = 1;
+                        $expect_warnings_for_malformed = 1;
                     }
-
-                    my $message;
-                    if (@malformations && grep { $_ !~ /overlong/ } @malformations) {
-                        $message = qr/\Q$non_cp_trailing_text\E/;
+                    elsif ($warning_type == 1) {
+                        $eval_warn = "no warnings";
+                        $expect_regular_warnings = 0;
+                        $expect_warnings_for_overflow = 0;
+                        $expect_warnings_for_malformed = 0;
+                    }
+                    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 = 1;
+                    }
+                    elsif ($warning_type == 3) {
+                        $eval_warn = "no warnings; use warnings"
+                                   . " '$trial_warning_category'";
+                        $expect_regular_warnings
+                            = (   $trial_warning_category eq $controlling_warning_category
+                               && $use_warn_flag);
+                        $expect_warnings_for_overflow
+                                    = $trial_warning_category eq 'non_unicode';
+                        $expect_warnings_for_malformed = 0;
+                    }
+                    elsif ($warning_type == 4) {  # Like type 3, but uses the
+                                                  # above-31-bit flags
+                        # The complement flags were set up so that the
+                        # above-31-bit 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 above-31-bit flags.
+                        next if ! $will_overflow && $allowed_uv < 0x80000000;
+                        next if $trial_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_ABOVE_31_BIT;
+                        $this_utf8n_flag_to_disallow
+                                                = $::UTF8_DISALLOW_ABOVE_31_BIT;
+                        $this_uvchr_flag_to_warn = $::UNICODE_WARN_ABOVE_31_BIT;
+                        $this_uvchr_flag_to_disallow
+                                             = $::UNICODE_DISALLOW_ABOVE_31_BIT;
                     }
                     else {
-                        $message = $cp_message_qr;
+                       die "Unexpected warning type '$warning_type'";
                     }
 
-                    my $malformations_name = join "/", @malformations;
-                    $malformations_name .= " malformation"
-                                                if $malformations_name;
-                    $malformations_name .= "s" if @malformations > 1;
+                    # 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;
+
+                    my $this_warning_flags = ($use_warn_flag)
+                                             ? $this_utf8n_flag_to_warn
+                                             : 0;
+                    my $this_disallow_flags = ($do_disallow)
+                                             ? $this_utf8n_flag_to_disallow
+                                             : 0;
                     my $this_bytes = $bytes;
                     my $this_length = $length;
                     my $expected_uv = $allowed_uv;
                     my $this_expected_len = $length;
                     my $this_needed_to_discern_len = $needed_to_discern_len;
-                    if ($malformations_name) {
-                        $expected_uv = 0;
 
-                        # Coerce the input into the desired
-                        # malformation
-                        if ($malformations_name =~ /overlong/) {
+                    my @malformation_names;
+                    my @expected_warnings;
+                    my @expected_return_flags;
 
+                    # Now go through the possible malformations wanted,  and
+                    # change the input accordingly.  We also can set up
+                    # certain other things now, like whether we expect a
+                    # return flag from this malformation and which flag.
+                    if ($overlong) {
                             # For an overlong, we convert the original
                             # start byte into a continuation byte with
                             # the same data bits as originally. ...
@@ -721,62 +818,151 @@ foreach my $test (@tests) {
                                                - $this_needed_to_discern_len);
                             $this_expected_len = $::max_bytes;
                             push @expected_return_flags, $::UTF8_GOT_LONG;
+                        push @malformation_names, $overlong;
+                        if ($expect_warnings_for_malformed) {
+                            if (   ! $short
+                                && ! $unexpected_noncont
+                                && ! $will_overflow)
+                            {
+                                my $overlong_bytes
+                                        = display_bytes_no_quotes($this_bytes);
+                                my $correct_bytes
+                                             = display_bytes_no_quotes($bytes);
+                                push @expected_warnings,
+                                     qr/\QMalformed UTF-8 character:\E
+                                        \Q $overlong_bytes (overlong;\E
+                                        \Q instead use $correct_bytes to\E
+                                        \Q represent U+$uv_string)/x;
+                            }
+                            else {
+                                push @expected_warnings, qr/overlong/;
+                            }
                         }
-                        if ($malformations_name =~ /short/) {
+                    }
 
-                            # Just tell the test to not look far
-                            # enough into the input.
-                            $this_length--;
-                            $this_expected_len--;
-                            push @expected_return_flags, $::UTF8_GOT_SHORT;
-                        }
-                        if ($malformations_name
-                                                =~ /non-continuation/)
-                        {
-                            # Change the final continuation byte into
-                            # a non one.
-                            my $pos = ($short) ? -2 : -1;
-                            substr($this_bytes, $pos, 1) = '?';
-                            $this_expected_len--;
-                            push @expected_return_flags,
-                                            $::UTF8_GOT_NON_CONTINUATION;
+                    if ($short) {
+                        push @malformation_names, $short;
+                        push @expected_warnings, qr/short/
+                                            if $expect_warnings_for_malformed;
+
+                        # To force this malformation, just tell the test to
+                        # not look as far as it should into the input.
+                        $this_length--;
+                        $this_expected_len--;
+                        push @expected_return_flags, $::UTF8_GOT_SHORT;
+                    }
+
+                    if ($unexpected_noncont) {
+                        push @malformation_names, $unexpected_noncont;
+                        push @expected_warnings, qr/$unexpected_noncont/
+                                            if $expect_warnings_for_malformed;
+
+                        # To force this malformation, change the final
+                        # continuation byte into a non continuation.
+                        my $pos = ($short) ? -2 : -1;
+                        substr($this_bytes, $pos, 1) = '?';
+                        $this_expected_len--;
+                        push @expected_return_flags,
+                                        $::UTF8_GOT_NON_CONTINUATION;
+                    }
+
+                    # 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;
+
+                        push @malformation_names, 'overflow';
+                        if ($expect_warnings_for_overflow) {
+                            my $qr = display_bytes_no_quotes(
+                                   substr($this_bytes, 0, $this_expected_len));
+                            $qr = qr/\QMalformed UTF-8 character: \E
+                                     \Q$qr (overflows)\E/x;
+                            push @expected_warnings, $qr;
                         }
+                        push @expected_return_flags, $::UTF8_GOT_OVERFLOW;
                     }
 
-                    my $eval_warn = $do_warning
-                                ? "use warnings '$trial_warning_category'"
-                                : $trial_warning_category eq "utf8"
-                                    ? "no warnings 'utf8'"
-                                    : ( "use warnings 'utf8';"
-                                    . " no warnings '$trial_warning_category'");
+                    # Here, we've set things up based on the malformations.
+                    # Now generate the text for them for the test name.
+                    my $malformations_name = "";
+                    if (@malformation_names) {
+                        $malformations_name .= "malformation";
+                        $malformations_name .= "s" if @malformation_names > 1;
+                        $malformations_name .= ": ";
+                        $malformations_name .=  join "/", @malformation_names;
+                        $malformations_name =  " ($malformations_name)";
+                    }
+
+                    # 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, $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) {
+                            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 $non_cp_trailing_text\E/x;
+                        }
+                    }
 
                     # Is effectively disallowed if we've set up a
                     # malformation, even if the flag indicates it is
                     # allowed.  Fix up test name to indicate this as
                     # well
-                    my $disallowed = $disallow_flag
-                                || $malformations_name;
+                    my $disallowed = (  $this_disallow_flags
+                                      & $this_utf8n_flag_to_disallow)
+                                  || $malformations_name;
                     my $this_name = "utf8n_to_uvchr_error() $testname: "
-                                                . (($disallow_flag)
-                                                ? 'disallowed'
-                                                : $disallowed
-                                                    ? $disallowed
-                                                    : 'allowed');
+                                                . (($disallowed)
+                                                   ? 'disallowed'
+                                                   : 'allowed');
                     $this_name .= ", $eval_warn";
-                    $this_name .= ", " . (($warn_flag)
-                                        ? 'with warning flag'
-                                        : 'no warning flag');
-
+                    $this_name .= ", " . ((  $this_warning_flags
+                                            & $this_utf8n_flag_to_warn)
+                                          ? 'with flag for raising warnings'
+                                          : 'no flag for raising warnings');
+                    $this_name .= $malformations_name;
+                    local $TODO = "High code point tests temporarily broken"
+                                                   if $allowed_uv > 0x7FFFFFFF;
                     undef @warnings_gotten;
                     my $ret_ref;
-                    my $this_flags = $warn_flag | $disallow_flag;
+                    my $this_flags = $this_warning_flags|$this_disallow_flags;
                     my $eval_text =      "$eval_warn; \$ret_ref"
                             . " = test_utf8n_to_uvchr_error("
-                            . "'$this_bytes',"
-                            . " $this_length, $this_flags)";
+                            . "'$this_bytes', $this_length, $this_flags)";
                     eval "$eval_text";
-                    if (! ok ("$@ eq ''",
-                        "$this_name: eval succeeded"))
+                    if (! ok ("$@ eq ''", "$this_name: eval succeeded"))
                     {
                         diag "\$@='$@'; call was: "
                            . utf8n_display_call($eval_text);
@@ -800,107 +986,61 @@ foreach my $test (@tests) {
                     my $returned_flags = $ret_ref->[2];
 
                     for (my $i = @expected_return_flags - 1; $i >= 0; $i--) {
-                        if (ok($expected_return_flags[$i] & $returned_flags,
-                            "    Expected and got return flag"
-                            . " for $malformations[$i] malformation"))
-                        {
+                        if ($expected_return_flags[$i] & $returned_flags) {
+                            if ($expected_return_flags[$i]
+                                            == $::UTF8_DISALLOW_ABOVE_31_BIT)
+                            {
+                                pass("    Expected and got return flag for"
+                                   . " above_31_bit");
+                            }
+                                   # The first entries in this are
+                                   # malformations
+                            elsif ($i > @malformation_names - 1)  {
+                                pass("    Expected and got return flag"
+                                   . " for " . $trial_warning_category);
+                            }
+                            else {
+                                pass("    Expected and got return flag for "
+                                   . $malformation_names[$i]
+                                   . " malformation");
+                            }
                             $returned_flags &= ~$expected_return_flags[$i];
+                            splice @expected_return_flags, $i, 1;
                         }
-                        splice @expected_return_flags, $i, 1;
                     }
-                    is(scalar @expected_return_flags, 0,
-                            "    Got all the expected malformation errors")
-                      or diag Dumper \@expected_return_flags;
 
-                    if (   $this_expected_len >= $this_needed_to_discern_len
-                        && ($warn_flag || $disallow_flag))
-                    {
-                        is($returned_flags, $expected_error_flags,
-                                "    Got the correct error flag")
-                          or diag "Call was: " . utf8n_display_call($eval_text);
-                    }
-                    else {
-                        is($returned_flags, 0, "    Got no other error flag")
-                        or
-
-                        # We strip off any prefixes from the flag names
-                        diag "The unexpected flags were: "
+                    is($returned_flags, 0,
+                       "    Got no unexpected return flags")
+                      or 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);
+                    is (scalar @expected_return_flags, 0,
+                        "    Got all expected return flags")
+                        or diag "The expected flags not gotten were: "
+                           . (flags_to_text(eval join("|",
+                                                        @expected_return_flags),
+                                            \@utf8n_flags_to_text)
+                                # We strip off any prefixes from the flag
+                                # names
                              =~ s/ \b [A-Z] _ //xgr);
-                    }
-
-                    if (@malformations) {
-                        if (! $do_warning && $trial_warning_category eq 'utf8') {
-                            goto no_warnings_expected;
-                        }
-
-                        # Check that each malformation generates a
-                        # warning, removing that warning if found
-                    MALFORMATION:
-                        foreach my $malformation (@malformations) {
-                            foreach (my $i = 0; $i < @warnings_gotten; $i++) {
-                                if ($warnings_gotten[$i] =~ /$malformation/) {
-                                    pass("    Expected and got"
-                                    . "'$malformation' warning");
-                                    splice @warnings_gotten, $i, 1;
-                                    next MALFORMATION;
-                                }
-                            }
-                            fail("    Expected '$malformation' warning"
-                               . " but didn't get it");
-
-                        }
-                    }
-
-                    # Any overflow will override any super or above-31
-                    # warnings.
-                    goto no_warnings_expected
-                                if $will_overflow || $this_expected_len
-                                        < $this_needed_to_discern_len;
-
-                    if (    ! $do_warning
-                        && (   $trial_warning_category eq 'utf8'
-                            || $trial_warning_category eq $controlling_warning_category))
-                    {
-                        goto no_warnings_expected;
-                    }
-                    elsif ($warn_flag) {
-                        if (is(scalar @warnings_gotten, 1,
-                            "    Got a single warning "))
-                        {
-                            like($warnings_gotten[0], $message,
-                                    "    Got expected warning")
-                                or diag "Call was: "
-                                      . utf8n_display_call($eval_text);
-                        }
-                        else {
-                            diag "Call was: " . utf8n_display_call($eval_text);
-                            if (scalar @warnings_gotten) {
-                                output_warnings(@warnings_gotten);
-                            }
-                        }
-                    }
-                    else {
 
-                    no_warnings_expected:
-                        unless (is(scalar @warnings_gotten, 0,
-                                "    Got no warnings"))
-                        {
-                            diag "Call was: " . utf8n_display_call($eval_text);
-                            output_warnings(@warnings_gotten);
-                        }
-                    }
+                    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 $disallow_flag is set
+                    # not just when the $this_disallow_flags is set
                     if ($disallowed) {
-                        undef @warnings_gotten;
-                        $this_flags = $disallow_flag|$::UTF8_CHECK_ONLY;
-                        $eval_text = "\$ret_ref = test_utf8n_to_uvchr_error("
-                                   . "'$this_bytes', $this_length, $this_flags)";
-                        eval "$eval_text";
+                        my $this_flags = $this_disallow_flags|$::UTF8_CHECK_ONLY;
+                        my $eval_text = "use warnings; no warnings 'deprecated'; \$ret_ref ="
+                                      . " test_utf8n_to_uvchr_error('"
+                                      . "$this_bytes', $this_length,"
+                                      . " $this_flags)";
+                        eval $eval_text;
                         if (! ok ("$@ eq ''",
                             "    And eval succeeded with CHECK_ONLY"))
                         {
@@ -925,36 +1065,35 @@ foreach my $test (@tests) {
                     # uvchr_to_utf8_flags().  Since this comes from an
                     # existing code point, it hasn't overflowed, and
                     # isn't malformed.
-                    next if @malformations;
-
-                    # The warning and disallow flags passed in are for
-                    # utf8n_to_uvchr_error().  Convert them for
-                    # uvchr_to_utf8_flags().
-                    my $uvchr_warn_flag = 0;
-                    my $uvchr_disallow_flag = 0;
-                    if ($warn_flag) {
-                        $uvchr_warn_flag = $uvchr_flag_to_warn;
-                    }
-                    if ($disallow_flag) {
-                        $uvchr_disallow_flag = $uvchr_flag_to_disallow;
-                    }
-
-                    $disallowed = $uvchr_disallow_flag;
+                    next if @malformation_names;
+
+                    $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_to_utf8_flags() $testname: "
-                                            . (($uvchr_disallow_flag)
+                                            . (($disallowed)
                                                 ? 'disallowed'
-                                                : ($disallowed)
-                                                ? 'ABOVE_31_BIT allowed'
                                                 : 'allowed');
                     $this_name .= ", $eval_warn";
-                    $this_name .= ", " . (($uvchr_warn_flag)
+                    $this_name .= ", " . ((  $this_warning_flags
+                                           & $this_uvchr_flag_to_warn)
                                         ? 'with warning flag'
                                         : 'no warning flag');
 
                     undef @warnings_gotten;
                     my $ret;
-                    $this_flags = $uvchr_warn_flag | $uvchr_disallow_flag;
+                    $this_flags = $this_warning_flags|$this_disallow_flags;
                     $eval_text = "$eval_warn; \$ret ="
                             . " test_uvchr_to_utf8_flags("
                             . "$allowed_uv, $this_flags)";
@@ -973,34 +1112,9 @@ foreach my $test (@tests) {
                         is($ret, $this_bytes, "    And returns expected string")
                           or diag "Call was: " . uvchr_display_call($eval_text);
                     }
-                    if (! $do_warning
-                        && ($trial_warning_category eq 'utf8' || $trial_warning_category eq $controlling_warning_category))
-                    {
-                        if (!is(scalar @warnings_gotten, 0,
-                                "    No warnings generated"))
-                        {
-                            diag "Call was: " . uvchr_display_call($eval_text);
-                            output_warnings(@warnings_gotten);
-                        }
-                    }
-                    elsif (       $uvchr_warn_flag
-                        && (   $trial_warning_category eq 'utf8'
-                            || $trial_warning_category eq $controlling_warning_category))
-                    {
-                        if (is(scalar @warnings_gotten, 1,
-                            "    Got a single warning "))
-                        {
-                            like($warnings_gotten[0], $message,
-                                    "    Got expected warning")
-                                or diag "Call was: "
-                                      . uvchr_display_call($eval_text);
-                        }
-                        else {
-                            diag "Call was: " . uvchr_display_call($eval_text);
-                            output_warnings(@warnings_gotten)
-                                                if scalar @warnings_gotten;
-                        }
-                    }
+
+                    do_warnings_test(@expected_warnings)
+                      or diag "Call was: " . uvchr_display_call($eval_text);
                 }
               }
             }