summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKarl Williamson <public@khwilliamson.com>2013-12-31 21:45:54 -0700
committerKarl Williamson <public@khwilliamson.com>2014-01-01 13:49:24 -0700
commit54f4afefabe5f838538f462f1e2bb40a64b6bb77 (patch)
treeeeeb292ec3148f721dad4964d36549386a406856
parent0cfa64bfe0ab570e7b2ddddfdad71f8341a5e6e1 (diff)
downloadperl-54f4afefabe5f838538f462f1e2bb40a64b6bb77.tar.gz
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.
-rw-r--r--ext/XS-APItest/t/utf8.t25
-rw-r--r--pod/perldiag.pod2
-rw-r--r--utf8.c12
3 files changed, 22 insertions, 17 deletions
diff --git a/ext/XS-APItest/t/utf8.t b/ext/XS-APItest/t/utf8.t
index 6a6ed9eaf4..b052a8633e 100644
--- 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 61d144ab2e..207f55c5f2 100644
--- 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 7eb4374ded..41e2c4caa6 100644
--- 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;