Locale tweakery. Add test case for bug id 20000809.003 to op/misc,

create a "fast path" for locale name probing using "locale -a"
if available, squash finally hopefully the s?printf resetting
the numeric locale (since, IIUC perllocale, it never shouldn't).

p4raw-id: //depot/perl@7540

diff --git a/sv.c b/sv.c
index 5fd6533..6feb489 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -6619,15 +6619,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                *--eptr = '#';
            *--eptr = '%';
 
-           {
-               STORE_NUMERIC_STANDARD_SET_LOCAL();
-#ifdef USE_LOCALE_NUMERIC
-               if (!was_standard && maybe_tainted)
-                   *maybe_tainted = TRUE;
-#endif
-               (void)sprintf(PL_efloatbuf, eptr, nv);
-               RESTORE_NUMERIC_STANDARD();
-           }
+           (void)sprintf(PL_efloatbuf, eptr, nv);
 
            eptr = PL_efloatbuf;
            elen = strlen(PL_efloatbuf);

diff --git a/t/op/misc.t b/t/op/misc.t
index f442494..0f10424 100755 (executable)
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -562,3 +562,36 @@ Modification of a read-only value attempted at - line 2.
 print qw(ab a\b a\\b);
 EXPECT
 aba\ba\b
+########
+# This test is here instead of pragma/locale.t because
+# the bug depends on in the internal state of the locale
+# settings and pragma/locale messes up that state pretty badly.
+# We need a "fresh run".
+use Config;
+my $have_setlocale = $Config{d_setlocale} eq 'define';
+eval {
+    require POSIX;
+};
+$have_setlocale = 0 if $@;
+# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
+# and mingw32 uses said silly CRT
+$have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i;
+exit(0) unless $have_setlocale;
+my @locales;
+if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) {
+    while(<LOCALES>) {
+        chomp;
+        push(@locales, $_);
+    }
+    close(LOCALES);
+}
+exit(0) unless @locales;
+for (@locales) {
+    use POSIX qw(locale_h);
+    use locale;
+    setlocale(LC_NUMERIC, $_) or die "setlocale(LC_NUMERIC, $_): $!";
+    my $s = sprintf "%g %g", 3.1, 3.1;
+    next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/;
+    print "$_ $s\n";
+}
+EXPECT

diff --git a/t/pragma/locale.t b/t/pragma/locale.t
index c8a0df8..82fb684 100755 (executable)
--- a/t/pragma/locale.t
+++ b/t/pragma/locale.t
@@ -242,13 +242,13 @@ Afrikaans:af:za:1 15
 Arabic:ar:dz eg sa:6 arabic8
 Brezhoneg Breton:br:fr:1 15
 Bulgarski Bulgarian:bg:bg:5
-Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW GB2312 tw.EUC
+Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC
 Hrvatski Croatian:hr:hr:2
 Cymraeg Welsh:cy:cy:1 14 15
 Czech:cs:cz:2
 Dansk Danish:dk:da:1 15
 Nederlands Dutch:nl:be nl:1 15
-English American British:en:au ca gb ie nz us uk:1 15 cp850
+English American British:en:au ca gb ie nz us uk zw:1 15 cp850
 Esperanto:eo:eo:3
 Eesti Estonian:et:ee:4 6 13
 Suomi Finnish:fi:fi:1 15
@@ -271,11 +271,12 @@ Latvian:lv:lv:4 6 13
 Lithuanian:lt:lt:4 6 13
 Macedonian:mk:mk:1 15
 Maltese:mt:mt:3
-Norsk Norwegian:no:no:1 15
+Moldovan:mo:mo:2
+Norsk Norwegian:no no\@nynorsk:no:1 15
 Occitan:oc:es:1 15
 Polski Polish:pl:pl:2
 Rumanian:ro:ro:2
-Russki Russian:ru:ru su ua:5 koi8 koi8r koi8u cp1251
+Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251
 Serbski Serbian:sr:yu:5
 Slovak:sk:sk:2
 Slovene Slovenian:sl:si:2
@@ -283,10 +284,11 @@ Sqhip Albanian:sq:sq:1 15
 Svenska Swedish:sv:fi se:1 15
 Thai:th:th:11 tis620
 Turkish:tr:tr:9 turkish8
-Yiddish:::1 15
+Yiddish:yi::1 15
 EOF
 
 if ($^O eq 'os390') {
+    # These cause heartburn.  Broken locales?
     $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//;
     $locales =~ s/Thai:th:th:11 tis620\n//;
 }
@@ -326,6 +328,7 @@ sub decode_encodings {
            }
        } else {
            push @enc, $_;
+           push @enc, "$_.UTF-8";
        }
     }
     if ($^O eq 'os390') {
@@ -347,32 +350,45 @@ foreach (0..15) {
     trylocale("iso_latin_$_");
 }
 
-foreach my $locale (split(/\n/, $locales)) {
-    my ($locale_name, $language_codes, $country_codes, $encodings) =
-       split(/:/, $locale);
-    my @enc = decode_encodings($encodings);
-    foreach my $loc (split(/ /, $locale_name)) {
-       trylocale($loc);
-       foreach my $enc (@enc) {
-           trylocale("$loc.$enc");
-       }
-       $loc = lc $loc;
-       foreach my $enc (@enc) {
-           trylocale("$loc.$enc");
-       }
+$ENV{PATH} = '/bin:/usr/bin';
+
+if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) {
+    while (<LOCALES>) {
+        chomp;
+       trylocale($_);
     }
-    foreach my $lang (split(/ /, $language_codes)) {
-       trylocale($lang);
-       foreach my $country (split(/ /, $country_codes)) {
-           my $lc = "${lang}_${country}";
-           trylocale($lc);
+    close(LOCALES);
+} else {
+
+    # This is going to be slow.
+
+    foreach my $locale (split(/\n/, $locales)) {
+       my ($locale_name, $language_codes, $country_codes, $encodings) =
+           split(/:/, $locale);
+       my @enc = decode_encodings($encodings);
+       foreach my $loc (split(/ /, $locale_name)) {
+           trylocale($loc);
            foreach my $enc (@enc) {
-               trylocale("$lc.$enc");
+               trylocale("$loc.$enc");
            }
-           my $lC = "${lang}_\U${country}";
-           trylocale($lC);
+           $loc = lc $loc;
            foreach my $enc (@enc) {
-               trylocale("$lC.$enc");
+               trylocale("$loc.$enc");
+           }
+       }
+       foreach my $lang (split(/ /, $language_codes)) {
+           trylocale($lang);
+           foreach my $country (split(/ /, $country_codes)) {
+               my $lc = "${lang}_${country}";
+               trylocale($lc);
+               foreach my $enc (@enc) {
+                   trylocale("$lc.$enc");
+               }
+               my $lC = "${lang}_\U${country}";
+               trylocale($lC);
+               foreach my $enc (@enc) {
+                   trylocale("$lC.$enc");
+               }
            }
        }
     }