This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add warning message for locale/Unicode intermixing
authorKarl Williamson <khw@cpan.org>
Thu, 6 Nov 2014 05:43:18 +0000 (22:43 -0700)
committerKarl Williamson <khw@cpan.org>
Fri, 14 Nov 2014 20:38:18 +0000 (13:38 -0700)
This is explained in the added perldiag entry.

embed.fnc
embed.h
lib/locale.t
pod/perldelta.pod
pod/perldiag.pod
pod/perlfunc.pod
proto.h
t/lib/warnings/utf8
t/re/fold_grind.t
utf8.c

index 7de7d84..9f3539e 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2462,7 +2462,12 @@ sn       |NV|mulexp10    |NV value|I32 exponent
 #endif
 
 #if defined(PERL_IN_UTF8_C)
-sRM    |UV     |check_locale_boundary_crossing|NN const U8* const p|const UV result|NN U8* const ustrp|NN STRLEN *lenp
+sRM    |UV     |check_locale_boundary_crossing                             \
+               |NN const char * const func_name                            \
+               |NN const U8* const p                                       \
+               |const UV result                                            \
+               |NN U8* const ustrp                                         \
+               |NN STRLEN *lenp
 iR     |bool   |is_utf8_common |NN const U8 *const p|NN SV **swash|NN const char * const swashname|NULLOK SV* const invlist
 sR     |SV*    |swatch_get     |NN SV* swash|UV start|UV span
 sRM    |U8*    |swash_scan_list_line|NN U8* l|NN U8* const lend|NN UV* min \
diff --git a/embed.h b/embed.h
index 0f53421..32ef097 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define isa_lookup(a,b,c,d)    S_isa_lookup(aTHX_ a,b,c,d)
 #  endif
 #  if defined(PERL_IN_UTF8_C)
-#define check_locale_boundary_crossing(a,b,c,d)        S_check_locale_boundary_crossing(aTHX_ a,b,c,d)
+#define check_locale_boundary_crossing(a,b,c,d,e)      S_check_locale_boundary_crossing(aTHX_ a,b,c,d,e)
 #define is_utf8_common(a,b,c,d)        S_is_utf8_common(aTHX_ a,b,c,d)
 #define swash_scan_list_line(a,b,c,d,e,f,g)    S_swash_scan_list_line(aTHX_ a,b,c,d,e,f,g)
 #define swatch_get(a,b,c)      S_swatch_get(aTHX_ a,b,c)
index cb0873a..b6193c6 100644 (file)
@@ -2381,6 +2381,7 @@ setlocale(&POSIX::LC_ALL, "C");
                     my $should_be;
                     my $changed;
                     if (! $is_utf8_locale) {
+                        no warnings 'locale';
                         $should_be = ($j == $#list)
                             ? chr(ord($char) + $above_latin1_case_change_delta)
                             : (length $char == 0 || ord($char) > 127)
index 49d2125..7bc77bd 100644 (file)
@@ -218,6 +218,10 @@ XXX L<message|perldiag/"message">
 
 L<Use of literal non-graphic characters in variable names is deprecated|perldiag/"Use of literal non-graphic characters in variable names is deprecated">
 
+=item *
+
+L<Can't do %s("%s") on non-UTF-8 locale; resolved to "%s".|perldiag/Can't do %s("%s") on non-UTF-8 locale; resolved to "%s".>
+
 =back
 
 =head2 Changes to Existing Diagnostics
index 4249a7d..846a93c 100644 (file)
@@ -741,6 +741,33 @@ C<foreach> loop nor a C<given> block.  (Note that this error is
 issued on exit from the C<default> block, so you won't get the
 error if you use an explicit C<continue>.)
 
+=item Can't do %s("%s") on non-UTF-8 locale; resolved to "%s".
+
+(W locale) You are 1) running under "C<use locale>"; 2) the current
+locale is not a UTF-8 one; 3) you tried to do the designated case-change
+operation on the specified Unicode character; and 4) the result of this
+operation would mix Unicode and locale rules, which likely conflict.
+Mixing of different rule types is forbidden, so the operation was not
+done; instead the result is the indicated value, which is the best
+available that uses entirely Unicode rules.  That turns out to almost
+always be the original character, unchanged.
+
+It is generally a bad idea to mix non-UTF-8 locales and Unicode, and
+this issue is one of the reasons why.  This warning is raised when
+Unicode rules would normally cause the result of this operation to
+contain a character that is in the range specified by the locale,
+0..255, and hence is subject to the locale's rules, not Unicode's.
+
+If you are using locale purely for its characteristics related to things
+like its numeric and time formatting (and not C<LC_CTYPE>), consider
+using a restricted form of the locale pragma (see L<perllocale/The "use
+locale" pragma>) like "S<C<use locale ':not_characters'>>".
+
+Note that failed case-changing operations done as a result of
+case-insensitive C</i> regular expression matching will show up in this
+warning as having the C<fc> operation (as that is what the regular
+expression engine calls behind the scenes.)
+
 =item Can't do inplace edit: %s is not a regular file
 
 (S inplace) You tried to use the B<-i> switch on a special file, such as
index e35bec6..8e8ea50 100644 (file)
@@ -3372,8 +3372,10 @@ locale), the lower case of U+1E9E is
 itself, because 0xDF may not be LATIN SMALL LETTER SHARP S in the
 current locale, and Perl has no way of knowing if that character even
 exists in the locale, much less what code point it is.  Perl returns
-the input character unchanged, for all instances (and there aren't
-many) where the 255/256 boundary would otherwise be crossed.
+a result that is above 255 (almost always the input character unchanged,
+for all instances (and there aren't many) where the 255/256 boundary
+would otherwise be crossed; and starting in v5.22, it raises a
+L<locale|perldiag/Can't do %s("%s") on non-UTF-8 locale; resolved to "%s".> warning.
 
 =item Otherwise, If EXPR has the UTF8 flag set:
 
diff --git a/proto.h b/proto.h
index 5b08806..03a36f0 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -7845,13 +7845,14 @@ STATIC bool     S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U
 
 #endif
 #if defined(PERL_IN_UTF8_C)
-STATIC UV      S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
+STATIC UV      S_check_locale_boundary_crossing(pTHX_ const char * const func_name, const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1)
-                       __attribute__nonnull__(pTHX_3)
-                       __attribute__nonnull__(pTHX_4);
+                       __attribute__nonnull__(pTHX_2)
+                       __attribute__nonnull__(pTHX_4)
+                       __attribute__nonnull__(pTHX_5);
 #define PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING        \
-       assert(p); assert(ustrp); assert(lenp)
+       assert(func_name); assert(p); assert(ustrp); assert(lenp)
 
 PERL_STATIC_INLINE bool        S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, const char * const swashname, SV* const invlist)
                        __attribute__warn_unused_result__
index 614d5ec..3690ce1 100644 (file)
@@ -581,3 +581,25 @@ print $fh "\x{10FFFF}", "\n";
 print $fh "\x{110000}", "\n";
 close $fh;
 EXPECT
+########
+# NAME Case change crosses 255/256 under non-UTF8 locale
+eval { require POSIX; POSIX->import("locale_h") };
+if ($@) {
+    print("SKIPPED\n# no POSIX\n"),exit;
+}
+use warnings 'locale';
+use feature 'fc';
+use locale;
+setlocale(&POSIX::LC_CTYPE, "C");
+my $a;
+$a = lc("\x{178}");
+$a = fc("\x{1E9E}");
+$a = fc("\x{FB05}");
+$a = uc("\x{FB00}");
+$a = ucfirst("\x{149}");
+EXPECT
+Can't do lc("\x{178}") on non-UTF-8 locale; resolved to "\x{178}". at - line 10.
+Can't do fc("\x{1E9E}") on non-UTF-8 locale; resolved to "\x{17F}\x{17F}". at - line 11.
+Can't do fc("\x{FB05}") on non-UTF-8 locale; resolved to "\x{FB06}". at - line 12.
+Can't do uc("\x{FB00}") on non-UTF-8 locale; resolved to "\x{FB00}". at - line 13.
+Can't do ucfirst("\x{149}") on non-UTF-8 locale; resolved to "\x{149}". at - line 14.
index f8e91cf..3fb11e5 100644 (file)
@@ -20,6 +20,7 @@ my $DEBUG = 0;  # Outputs extra information for debugging this .t
 
 use strict;
 use warnings;
+no warnings 'locale';   # Plenty of these would otherwise get generated
 use Encode;
 use POSIX;
 
diff --git a/utf8.c b/utf8.c
index f42b1a2..cd38768 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -1873,7 +1873,7 @@ Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
 }
 
 STATIC UV
-S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
+S_check_locale_boundary_crossing(pTHX_ const char * const func_name, const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
 {
     /* This is called when changing the case of a utf8-encoded character above
      * the Latin1 range, and the operation is in a non-UTF-8 locale.  If the
@@ -1916,6 +1916,14 @@ bad_crossing:
 
     /* Failed, have to return the original */
     original = valid_utf8_to_uvchr(p, lenp);
+
+    /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
+    Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
+                           "Can't do %s(\"\\x{%"UVXf"}\") on non-UTF-8 locale; "
+                           "resolved to \"\\x{%"UVXf"}\".",
+                           func_name,
+                           original,
+                           original);
     Copy(p, ustrp, *lenp, char);
     return original;
 }
@@ -1964,7 +1972,7 @@ Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags
        result = CALL_UPPER_CASE(p, ustrp, lenp);
 
        if (flags) {
-           result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+           result = check_locale_boundary_crossing("uc", p, result, ustrp, lenp);
        }
        return result;
     }
@@ -2029,7 +2037,7 @@ Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags
        result = CALL_TITLE_CASE(p, ustrp, lenp);
 
        if (flags) {
-           result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+           result = check_locale_boundary_crossing("ucfirst", p, result, ustrp, lenp);
        }
        return result;
     }
@@ -2093,7 +2101,7 @@ Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags
        result = CALL_LOWER_CASE(p, ustrp, lenp);
 
        if (flags) {
-           result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+           result = check_locale_boundary_crossing("lc", p, result, ustrp, lenp);
        }
 
        return result;
@@ -2177,15 +2185,23 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags)
                 && memEQ((char *) p, LATIN_CAPITAL_LETTER_SHARP_S_UTF8,
                           sizeof(LATIN_CAPITAL_LETTER_SHARP_S_UTF8) - 1))
             {
+                /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
+                Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
+                              "Can't do fc(\"\\x{1E9E}\") on non-UTF-8 locale; "
+                              "resolved to \"\\x{17F}\\x{17F}\".");
                 goto return_long_s;
             }
             else if (UTF8SKIP(p) == sizeof(LATIN_SMALL_LIGATURE_LONG_S_T) - 1
                 && memEQ((char *) p, LATIN_SMALL_LIGATURE_LONG_S_T_UTF8,
                           sizeof(LATIN_SMALL_LIGATURE_LONG_S_T_UTF8) - 1))
             {
+                /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
+                Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
+                              "Can't do fc(\"\\x{FB05}\") on non-UTF-8 locale; "
+                              "resolved to \"\\x{FB06}\".");
                 goto return_ligature_st;
             }
-           return check_locale_boundary_crossing(p, result, ustrp, lenp);
+           return check_locale_boundary_crossing("fc", p, result, ustrp, lenp);
        }
        else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) {
            return result;