utf8.c: Fix warning category and subcategory conflicts

The warnings categories non_unicode, nonchar, and surrogate are all
subcategories of 'utf8'.  One should never call a packWARN() with both a
category and a subcategory of it, as it will mean that one can't
completely make the subcategory independent.  For example,

    use warnings 'utf8';
    no warnings 'surrogate';

surrogate warnings will be output if they are tested with a

    ckWARN2(WARN_UTF8, WARN_SURROGATE);

utf8.c was guilty of this.

diff --git a/ext/XS-APItest/t/utf8.t b/ext/XS-APItest/t/utf8.t
index 6a6ed9e..b052a86 100644 (file)
--- a/ext/XS-APItest/t/utf8.t
+++ b/ext/XS-APItest/t/utf8.t
@@ -202,12 +202,16 @@ foreach my $test (@tests) {
     # 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 $warning (0, 'utf8', 'surrogate', 'nonchar', 'non_unicode') {
+    foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
         foreach my $warn_flag (0, $warn_flags) {
             foreach my $disallow_flag (0, $disallow_flags) {
+                foreach my $do_warning (0, 1) {
 
-                no warnings 'utf8';
-                my $eval_warn = $warning eq 0 ? "no warnings" : "use warnings '$warning'";
+                my $eval_warn = $do_warning
+                                ? "use warnings '$warning'"
+                                : $warning eq "utf8"
+                                  ? "no warnings 'utf8'"
+                                  : "use warnings 'utf8'; no warnings '$warning'";
 
                 # is effectively disallowed if will overflow, even if the flag
                 # indicates it is allowed, fix up test name to indicate this
@@ -239,7 +243,13 @@ foreach my $test (@tests) {
                 }
                 is($ret_ref->[1], $expected_len, "$this_name: Returns expected length");
 
-                if ($will_overflow && ! $disallow_flag && $warning eq 'utf8') {
+                if (! $do_warning && ($warning eq 'utf8' || $warning eq $category)) {
+                    if (!is(scalar @warnings, 0, "$this_name: No warnings generated"))
+                    {
+                        note "The warnings were: " . join(", ", @warnings);
+                    }
+                }
+                elsif ($will_overflow && ! $disallow_flag && $warning eq 'utf8') {
 
                     # Will get the overflow message instead of the expected
                     # message under these circumstances, as they would
@@ -264,12 +274,6 @@ foreach my $test (@tests) {
                         }
                     }
                 }
-                else {
-                    if (!is(scalar @warnings, 0, "$this_name: No warnings generated"))
-                    {
-                        note "The warnings were: " . join(", ", @warnings);
-                    }
-                }
 
                 # Check CHECK_ONLY results when the input is disallowed.  Do
                 # this when actually disallowed, not just when the
@@ -285,6 +289,7 @@ foreach my $test (@tests) {
                 }
             }
         }
+        }
     }
 }
 

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 61d144a..207f55c 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -3672,7 +3672,7 @@ the C<fallback> overloading key is specified to be true.  See L<overload>.
 
 =item Operation "%s" returns its argument for non-Unicode code point 0x%X
 
-(S utf8, non_unicode) You performed an operation requiring Unicode
+(S non_unicode) You performed an operation requiring Unicode
 semantics on a code point that is not in Unicode, so what it should do
 is not defined.  Perl has chosen to have it do nothing, and warn you.
 

diff --git a/utf8.c b/utf8.c
index 7eb4374..41e2c4c 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -831,10 +831,10 @@ Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
     {
        if (UNICODE_IS_SURROGATE(uv)) {
            if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE
-               && ckWARN2_d(WARN_UTF8, WARN_SURROGATE))
+               && ckWARN_d(WARN_SURROGATE))
            {
                sv = sv_2mortal(Perl_newSVpvf(aTHX_ "UTF-16 surrogate U+%04"UVXf"", uv));
-               pack_warn = packWARN2(WARN_UTF8, WARN_SURROGATE);
+               pack_warn = packWARN(WARN_SURROGATE);
            }
            if (flags & UTF8_DISALLOW_SURROGATE) {
                goto disallowed;
@@ -842,10 +842,10 @@ Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
        }
        else if ((uv > PERL_UNICODE_MAX)) {
            if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER
-               && ckWARN2_d(WARN_UTF8, WARN_NON_UNICODE))
+               && ckWARN_d(WARN_NON_UNICODE))
            {
                sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv));
-               pack_warn = packWARN2(WARN_UTF8, WARN_NON_UNICODE);
+               pack_warn = packWARN(WARN_NON_UNICODE);
            }
            if (flags & UTF8_DISALLOW_SUPER) {
                goto disallowed;
@@ -853,10 +853,10 @@ Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
        }
        else if (UNICODE_IS_NONCHAR(uv)) {
            if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR
-               && ckWARN2_d(WARN_UTF8, WARN_NONCHAR))
+               && ckWARN_d(WARN_NONCHAR))
            {
                sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv));
-               pack_warn = packWARN2(WARN_UTF8, WARN_NONCHAR);
+               pack_warn = packWARN(WARN_NONCHAR);
            }
            if (flags & UTF8_DISALLOW_NONCHAR) {
                goto disallowed;