Don't raise Wide char warning in UTF-8 locale

This belongs in the category of "I can't believe I did that." Commit 613abc6 introduced warning messages when a multi-byte character is operated on in a single byte locale. But the two macros introduced fail to suppress said messages when in a multi-byte locale where the operation is perfectly valid. This partially solves v5.22 blocker [perl #123527]. But it could still fail if the test files are called from within a non-UTF-8 locale. I will issue a pull request for fixing that.
Perl · Mar 28, 2015 · 008e8e8 · 008e8e8
1 parent 2b79cfe
commit 008e8e8
Show file tree

Hide file tree

Showing 3 changed files with 56 additions and 3 deletions.
diff --git a/perl.h b/perl.h
@@ -5826,12 +5826,17 @@ typedef struct am_table_short AMTS;
      * argument; the 2nd, is a pointer to the first byte of the UTF-8 encoded
      * string, and an end position which it won't try to read past */
 #   define _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(cp)                         \
-      Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),                           \
-             "Wide character (U+%"UVXf") in %s", (UV) cp, OP_DESC(PL_op));
+	STMT_START {                                                        \
+            if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) {         \
+                Perl_warner(aTHX_ packWARN(WARN_LOCALE),                    \
+                                        "Wide character (U+%"UVXf") in %s", \
+                                        (UV) cp, OP_DESC(PL_op));           \
+            }                                                               \
+        }  STMT_END
 
 #  define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(s, send)                   \
 	STMT_START { /* Check if to warn before doing the conversion work */\
-            if (ckWARN(WARN_LOCALE)) {                                      \
+            if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) {         \
                 UV cp = utf8_to_uvchr_buf((U8 *) s, (U8 *) send, NULL);     \
                 Perl_warner(aTHX_ packWARN(WARN_LOCALE),                    \
                     "Wide character (U+%"UVXf") in %s",                     \

diff --git a/t/lib/warnings/regexec b/t/lib/warnings/regexec
@@ -148,6 +148,29 @@ Wide character (U+100) in pattern match (m//) at - line 15.
 Wide character (U+100) in pattern match (m//) at - line 16.
 Wide character (U+100) in pattern match (m//) at - line 16.
 ########
+# NAME Wide character in UTF-8 locale
+require '../loc_tools.pl';
+unless (locales_enabled()) {
+    print("SKIPPED\n# locales not available\n"),exit;
+}
+eval { require POSIX; POSIX->import("locale_h") };
+if ($@) {
+    print("SKIPPED\n# no POSIX\n"),exit;
+}
+my @utf8_locales = find_utf8_ctype_locale();
+unless (@utf8_locales) {
+    print("SKIPPED\n# no UTF-8 locales\n"),exit;
+}
+use warnings 'locale';
+use locale;
+setlocale(&POSIX::LC_CTYPE, $utf8_locales[0]);
+"\x{100}" =~ /\x{100}|\x{101}/il;
+"\x{100}" =~ /\x{100}|\x{101}/l;
+"\x{100}" =~ /\w/l;
+"\x{100}" =~ /\x{100}+/l;
+"\x{100}" =~ /[\x{100}\x{102}]/l;
+EXPECT
+########
 # NAME \b{} in non-UTF-8 locale
 eval { require POSIX; POSIX->import("locale_h") };
 if ($@) {

diff --git a/t/lib/warnings/utf8 b/t/lib/warnings/utf8
@@ -648,3 +648,28 @@ Wide character (U+101) in lcfirst at - line 15.
 Wide character (U+102) in fc at - line 16.
 Wide character (U+103) in uc at - line 17.
 Wide character (U+104) in ucfirst at - line 18.
+########
+# NAME Wide character in UTF-8 locale
+require '../loc_tools.pl';
+unless (locales_enabled('LC_CTYPE')) {
+    print("SKIPPED\n# locales not available\n"),exit;
+}
+eval { require POSIX; POSIX->import("locale_h") };
+if ($@) {
+    print("SKIPPED\n# no POSIX\n"),exit;
+}
+my @utf8_locales = find_utf8_ctype_locale();
+unless (@utf8_locales) {
+    print("SKIPPED\n# no UTF-8 locales\n"),exit;
+}
+use warnings 'locale';
+use feature 'fc';
+use locale;
+setlocale(&POSIX::LC_CTYPE, $utf8_locales[0]);
+my $a;
+$a = lc("\x{100}");
+$a = lcfirst("\x{101}");
+$a = fc("\x{102}");
+$a = uc("\x{103}");
+$a = ucfirst("\x{104}");
+EXPECT