This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fixed two long-standing locale bugs.
authorJarkko Hietaniemi <jhi@iki.fi>
Thu, 17 Jun 1999 22:42:03 +0000 (22:42 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Thu, 17 Jun 1999 22:42:03 +0000 (22:42 +0000)
Both problems were related to numeric locale which
controls the radix character aka the decimal separator.
(1) printf (and sprintf) were resetting the numeric locale to C.
(2) Using locale-numerically formatted floating point
    numbers (e.g. "1,23") together with -w caused warnings about
    "isn't numeric".  The operations were working fine, though,
    because atof() was using the local locale.
Both problems reported by Stefan Vogtner.

Introduced a wrapper for atof() that attempts to convert
the string both ways.  This helps Perl to understand
numbers like this "4.56" even when using a local locale
makes atof() understand only numbers like this "7,89".

Remaining related problems, both of which existed before
this patch and continue to exist after this patch:
(a) The behaviour of print() is _not_ as documented by perllocale.
    Instead of always using the C locale, print() does use the
    local locale, just like the *printf() do.  This may be fixable
    now that switching to-and-fro between locales has been made
    more consistent, but fixing print() would change existing
    behaviour.  perllocale is not changed by this patch.
(b) If a number has been stringified (say, via "$number") under
    a local locale, the cached string value persists even under
    "no locale".  This may or may not be a problem: operations
    work fine because the original number is still there, but
    that the string form keeps its locale-ish outlook may be
    somewhat confusing.

p4raw-id: //depot/cfgperl@3542

18 files changed:
dump.c
embed.h
embed.pl
embedvar.h
global.sym
intrpvar.h
mg.c
objXSUB.h
perl.c
perl.h
pp.c
pp_ctl.c
pp_sys.c
proto.h
sv.c
t/pragma/locale.t
toke.c
util.c

diff --git a/dump.c b/dump.c
index ef0d858..3d3a55c 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -277,8 +277,9 @@ Perl_sv_peek(pTHX_ SV *sv)
        }
     }
     else if (SvNOKp(sv)) {
-       SET_NUMERIC_STANDARD();
+       RESTORE_NUMERIC_STANDARD();
        Perl_sv_catpvf(aTHX_ t, "(%g)",SvNVX(sv));
+       RESTORE_NUMERIC_LOCAL();
     }
     else if (SvIOKp(sv)) {             /* XXXX: IV, UV? */
        if (SvIsUV(sv))
@@ -895,8 +896,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        PerlIO_putc(file, '\n');
     }
     if (type >= SVt_PVNV || type == SVt_NV) {
-       SET_NUMERIC_STANDARD();
+       RESTORE_NUMERIC_STANDARD();
        Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
+       RESTORE_NUMERIC_LOCAL();
     }
     if (SvROK(sv)) {
        Perl_dump_indent(aTHX_ level, file, "  RV = 0x%lx\n", (long)SvRV(sv));
diff --git a/embed.h b/embed.h
index 17acf1e..02a2cc2 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define mod                    Perl_mod
 #define moreswitches           Perl_moreswitches
 #define my                     Perl_my
+#ifdef USE_LOCALE_NUMERIC
+#define my_atof                        Perl_my_atof
+#endif
 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
 #define my_bcopy               Perl_my_bcopy
 #endif
 #define new_ctype              Perl_new_ctype
 #define new_numeric            Perl_new_numeric
 #define set_numeric_local      Perl_set_numeric_local
+#define set_numeric_radix      Perl_set_numeric_radix
 #define set_numeric_standard   Perl_set_numeric_standard
 #define require_pv             Perl_require_pv
 #define pidgone                        Perl_pidgone
 #define mod(a,b)               Perl_mod(aTHX_ a,b)
 #define moreswitches(a)                Perl_moreswitches(aTHX_ a)
 #define my(a)                  Perl_my(aTHX_ a)
+#ifdef USE_LOCALE_NUMERIC
+#define my_atof(a)             Perl_my_atof(aTHX_ a)
+#endif
 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
 #define my_bcopy(a,b,c)                Perl_my_bcopy(aTHX_ a,b,c)
 #endif
 #define new_ctype(a)           Perl_new_ctype(aTHX_ a)
 #define new_numeric(a)         Perl_new_numeric(aTHX_ a)
 #define set_numeric_local()    Perl_set_numeric_local(aTHX)
+#define set_numeric_radix()    Perl_set_numeric_radix(aTHX)
 #define set_numeric_standard() Perl_set_numeric_standard(aTHX)
 #define require_pv(a)          Perl_require_pv(aTHX_ a)
 #define pidgone(a,b)           Perl_pidgone(aTHX_ a,b)
 #define Perl_mod               CPerlObj::mod
 #define Perl_moreswitches      CPerlObj::moreswitches
 #define Perl_my                        CPerlObj::my
+#ifdef USE_LOCALE_NUMERIC
+#define Perl_my_atof           CPerlObj::my_atof
+#endif
 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
 #define Perl_my_bcopy          CPerlObj::my_bcopy
 #endif
 #define Perl_new_ctype         CPerlObj::new_ctype
 #define Perl_new_numeric       CPerlObj::new_numeric
 #define Perl_set_numeric_local CPerlObj::set_numeric_local
+#define Perl_set_numeric_radix CPerlObj::set_numeric_radix
 #define Perl_set_numeric_standard      CPerlObj::set_numeric_standard
 #define Perl_require_pv                CPerlObj::require_pv
 #define Perl_pidgone           CPerlObj::pidgone
index eb0d42c..6816740 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1040,6 +1040,9 @@ p |I32    |mg_size        |SV* sv
 p      |OP*    |mod            |OP* o|I32 type
 p      |char*  |moreswitches   |char* s
 p      |OP*    |my             |OP* o
+#ifdef USE_LOCALE_NUMERIC
+p      |double |my_atof        |const char *s
+#endif
 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
 p      |char*  |my_bcopy       |const char* from|char* to|I32 len
 #endif
@@ -1159,6 +1162,7 @@ p |void   |new_collate    |const char* newcoll
 p      |void   |new_ctype      |const char* newctype
 p      |void   |new_numeric    |const char* newcoll
 p      |void   |set_numeric_local
+p      |void   |set_numeric_radix
 p      |void   |set_numeric_standard
 no     |int    |perl_parse     |PerlInterpreter* sv_interp|XSINIT_t xsinit \
                                |int argc|char** argv|char** env
index 1312258..dbd94e9 100644 (file)
 #define PL_nthreads_cond       (PL_curinterp->Inthreads_cond)
 #define PL_numeric_local       (PL_curinterp->Inumeric_local)
 #define PL_numeric_name                (PL_curinterp->Inumeric_name)
+#define PL_numeric_radix       (PL_curinterp->Inumeric_radix)
 #define PL_numeric_standard    (PL_curinterp->Inumeric_standard)
 #define PL_ofmt                        (PL_curinterp->Iofmt)
 #define PL_oldbufptr           (PL_curinterp->Ioldbufptr)
 #define PL_Inthreads_cond      PL_nthreads_cond
 #define PL_Inumeric_local      PL_numeric_local
 #define PL_Inumeric_name       PL_numeric_name
+#define PL_Inumeric_radix      PL_numeric_radix
 #define PL_Inumeric_standard   PL_numeric_standard
 #define PL_Iofmt               PL_ofmt
 #define PL_Ioldbufptr          PL_oldbufptr
index f3e6494..0c3f72b 100644 (file)
@@ -280,6 +280,7 @@ Perl_mg_size
 Perl_mod
 Perl_moreswitches
 Perl_my
+Perl_my_atof
 Perl_my_bcopy
 Perl_my_bzero
 Perl_my_exit
@@ -382,6 +383,7 @@ Perl_new_collate
 Perl_new_ctype
 Perl_new_numeric
 Perl_set_numeric_local
+Perl_set_numeric_radix
 Perl_set_numeric_standard
 perl_parse
 Perl_require_pv
index 744ff31..0bf826e 100644 (file)
@@ -315,6 +315,8 @@ PERLVARI(Inumeric_standard, bool,   TRUE)
                                        /* Assume simple numerics */
 PERLVARI(Inumeric_local,       bool,   TRUE)
                                        /* Assume local numerics */
+PERLVAR(Inumeric_radix,                char)
+                                       /* The radix character if not '.' */
 
 #endif /* !USE_LOCALE_NUMERIC */
 
diff --git a/mg.c b/mg.c
index 96e4bd2..30253bc 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1941,10 +1941,9 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
            char *p = SvPV(sv, len);
            Groups_t gary[NGROUPS];
 
-           SET_NUMERIC_STANDARD();
            while (isSPACE(*p))
                ++p;
-           PL_egid = I_V(atof(p));
+           PL_egid = I_V(atol(p));
            for (i = 0; i < NGROUPS; ++i) {
                while (*p && !isSPACE(*p))
                    ++p;
@@ -1952,7 +1951,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                    ++p;
                if (!*p)
                    break;
-               gary[i] = I_V(atof(p));
+               gary[i] = I_V(atol(p));
            }
            if (i)
                (void)setgroups(i, gary);
index 579b916..c15c19d 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #define PL_numeric_local       pPerl->PL_numeric_local
 #undef  PL_numeric_name
 #define PL_numeric_name                pPerl->PL_numeric_name
+#undef  PL_numeric_radix
+#define PL_numeric_radix       pPerl->PL_numeric_radix
 #undef  PL_numeric_standard
 #define PL_numeric_standard    pPerl->PL_numeric_standard
 #undef  PL_ofmt
 #define moreswitches           pPerl->moreswitches
 #undef  my
 #define my                     pPerl->my
+#ifdef USE_LOCALE_NUMERIC
+#undef  my_atof
+#define my_atof                        pPerl->my_atof
+#endif
 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
 #undef  my_bcopy
 #define my_bcopy               pPerl->my_bcopy
 #define new_numeric            pPerl->new_numeric
 #undef  set_numeric_local
 #define set_numeric_local      pPerl->set_numeric_local
+#undef  set_numeric_radix
+#define set_numeric_radix      pPerl->set_numeric_radix
 #undef  set_numeric_standard
 #define set_numeric_standard   pPerl->set_numeric_standard
 #undef  require_pv
diff --git a/perl.c b/perl.c
index 6be4342..92c2eaf 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -964,7 +964,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
            Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
        else {
            Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
-               PL_origfilename);
+                      PL_origfilename);
        }
     }
     PL_curcop->cop_line = 0;
diff --git a/perl.h b/perl.h
index 60a41ea..7ef9432 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2817,10 +2817,22 @@ typedef struct am_table_short AMTS;
            set_numeric_local();                \
     } STMT_END
 
+#define IS_NUMERIC_RADIX(c)    \
+       ((PL_hints & HINT_LOCALE) && \
+         PL_numeric_radix && (c) == PL_numeric_radix)
+
+#define RESTORE_NUMERIC_LOCAL()                if ((PL_hints & HINT_LOCALE) && PL_numeric_standard) SET_NUMERIC_LOCAL()
+#define RESTORE_NUMERIC_STANDARD()     if ((PL_hints & HINT_LOCALE) && PL_numeric_local) SET_NUMERIC_STANDARD()
+#define Atof(s)                                Perl_my_atof(s)
+
 #else /* !USE_LOCALE_NUMERIC */
 
-#define SET_NUMERIC_STANDARD()  /**/
-#define SET_NUMERIC_LOCAL()     /**/
+#define SET_NUMERIC_STANDARD()         /**/
+#define SET_NUMERIC_LOCAL()            /**/
+#define IS_NUMERIC_RADIX(c)            (0)
+#define RESTORE_NUMERIC_LOCAL()                /**/
+#define RESTORE_NUMERIC_STANDARD()     /**/
+#define Atof(s)                                atof(s)
 
 #endif /* !USE_LOCALE_NUMERIC */
 
diff --git a/pp.c b/pp.c
index 8874b30..a42c611 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -1802,7 +1802,7 @@ PP(pp_log)
       double value;
       value = POPn;
       if (value <= 0.0) {
-       SET_NUMERIC_STANDARD();
+       RESTORE_NUMERIC_STANDARD();
        DIE(aTHX_ "Can't take log of %g", value);
       }
       value = log(value);
@@ -1818,7 +1818,7 @@ PP(pp_sqrt)
       double value;
       value = POPn;
       if (value < 0.0) {
-       SET_NUMERIC_STANDARD();
+       RESTORE_NUMERIC_STANDARD();
        DIE(aTHX_ "Can't take sqrt of %g", value);
       }
       value = sqrt(value);
@@ -2204,12 +2204,6 @@ PP(pp_rindex)
 PP(pp_sprintf)
 {
     djSP; dMARK; dORIGMARK; dTARGET;
-#ifdef USE_LOCALE_NUMERIC
-    if (PL_op->op_private & OPpLOCALE)
-       SET_NUMERIC_LOCAL();
-    else
-       SET_NUMERIC_STANDARD();
-#endif
     do_sprintf(TARG, SP-MARK, MARK+1);
     TAINT_IF(SvTAINTED(TARG));
     SP = ORIGMARK;
index 436498f..e4a7411 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -567,11 +567,16 @@ PP(pp_formline)
            gotsome = TRUE;
            value = SvNV(sv);
            /* Formats aren't yet marked for locales, so assume "yes". */
-           SET_NUMERIC_LOCAL();
-           if (arg & 256) {
-               sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
-           } else {
-               sprintf(t, "%*.0f", (int) fieldsize, value);
+           {
+               RESTORE_NUMERIC_LOCAL();
+               if (arg & 256) {
+                   sprintf(t, "%#*.*f",
+                           (int) fieldsize, (int) arg & 255, value);
+               } else {
+                   sprintf(t, "%*.0f",
+                           (int) fieldsize, value);
+               }
+               RESTORE_NUMERIC_STANDARD();
            }
            t += fieldsize;
            break;
@@ -2727,7 +2732,7 @@ S_doeval(pTHX_ int gimme, OP** startop)
        PERL_CONTEXT *cx;
        I32 optype = 0;                 /* Might be reset by POPEVAL. */
        STRLEN n_a;
-
+       
        PL_op = saveop;
        if (PL_eval_root) {
            op_free(PL_eval_root);
@@ -2854,8 +2859,7 @@ PP(pp_require)
 
     sv = POPs;
     if (SvNIOKp(sv) && !SvPOKp(sv)) {
-       SET_NUMERIC_STANDARD();
-       if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
+       if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
            DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
                SvPV(sv,n_a),PL_patchlevel);
        RETPUSHYES;
index 8eee944..9600174 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1356,12 +1356,6 @@ PP(pp_prtf)
        goto just_say_no;
     }
     else {
-#ifdef USE_LOCALE_NUMERIC
-       if (PL_op->op_private & OPpLOCALE)
-           SET_NUMERIC_LOCAL();
-       else
-           SET_NUMERIC_STANDARD();
-#endif
        do_sprintf(sv, SP - MARK, MARK + 1);
        if (!do_print(sv, fp))
            goto just_say_no;
diff --git a/proto.h b/proto.h
index 222654c..5251b5f 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -304,6 +304,9 @@ I32 Perl_mg_size(pTHX_ SV* sv);
 OP*    Perl_mod(pTHX_ OP* o, I32 type);
 char*  Perl_moreswitches(pTHX_ char* s);
 OP*    Perl_my(pTHX_ OP* o);
+#ifdef USE_LOCALE_NUMERIC
+double Perl_my_atof(pTHX_ const char *s);
+#endif
 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
 char*  Perl_my_bcopy(pTHX_ const char* from, char* to, I32 len);
 #endif
@@ -420,6 +423,7 @@ void        Perl_new_collate(pTHX_ const char* newcoll);
 void   Perl_new_ctype(pTHX_ const char* newctype);
 void   Perl_new_numeric(pTHX_ const char* newcoll);
 void   Perl_set_numeric_local(pTHX);
+void   Perl_set_numeric_radix(pTHX);
 void   Perl_set_numeric_standard(pTHX);
 int    perl_parse(PerlInterpreter* sv_interp, XSINIT_t xsinit, int argc, char** argv, char** env);
 void   Perl_require_pv(pTHX_ const char* pv);
diff --git a/sv.c b/sv.c
index edf1f1e..5fad33e 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1210,8 +1210,7 @@ Perl_sv_2iv(pTHX_ register SV *sv)
             * - otherwise future conversion to NV will be wrong.  */
            double d;
 
-           SET_NUMERIC_STANDARD();
-           d = atof(SvPVX(sv));
+           d = Atof(SvPVX(sv));
 
            if (SvTYPE(sv) < SVt_PVNV)
                sv_upgrade(sv, SVt_PVNV);
@@ -1351,8 +1350,7 @@ Perl_sv_2uv(pTHX_ register SV *sv)
             * - otherwise future conversion to NV will be wrong.  */
            double d;
 
-           SET_NUMERIC_STANDARD();
-           d = atof(SvPVX(sv));        /* XXXX 64-bit? */
+           d = Atof(SvPVX(sv));        /* XXXX 64-bit? */
 
            if (SvTYPE(sv) < SVt_PVNV)
                sv_upgrade(sv, SVt_PVNV);
@@ -1435,8 +1433,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
            dTHR;
            if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
                not_a_number(sv);
-           SET_NUMERIC_STANDARD();
-           return atof(SvPVX(sv));
+           return Atof(SvPVX(sv));
        }
        if (SvIOKp(sv)) {
            if (SvIsUV(sv)) 
@@ -1465,8 +1462,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
            if (SvPOKp(sv) && SvLEN(sv)) {
                if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
                    not_a_number(sv);
-               SET_NUMERIC_STANDARD();
-               return atof(SvPVX(sv));
+               return Atof(SvPVX(sv));
            }
            if (SvIOKp(sv)) {
                if (SvIsUV(sv)) 
@@ -1484,9 +1480,12 @@ Perl_sv_2nv(pTHX_ register SV *sv)
            sv_upgrade(sv, SVt_PVNV);
        else
            sv_upgrade(sv, SVt_NV);
-       DEBUG_c(SET_NUMERIC_STANDARD());
-       DEBUG_c(PerlIO_printf(Perl_debug_log,
-                             "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
+       DEBUG_c({
+           RESTORE_NUMERIC_STANDARD();
+           PerlIO_printf(Perl_debug_log,
+                         "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv));
+           RESTORE_NUMERIC_LOCAL();
+       });
     }
     else if (SvTYPE(sv) < SVt_PVNV)
        sv_upgrade(sv, SVt_PVNV);
@@ -1499,8 +1498,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
        dTHR;
        if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
            not_a_number(sv);
-       SET_NUMERIC_STANDARD();
-       SvNVX(sv) = atof(SvPVX(sv));
+       SvNVX(sv) = Atof(SvPVX(sv));
     }
     else  {
        dTHR;
@@ -1512,9 +1510,12 @@ Perl_sv_2nv(pTHX_ register SV *sv)
        return 0.0;
     }
     SvNOK_on(sv);
-    DEBUG_c(SET_NUMERIC_STANDARD());
-    DEBUG_c(PerlIO_printf(Perl_debug_log,
-                         "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
+    DEBUG_c({
+       RESTORE_NUMERIC_STANDARD();
+       PerlIO_printf(Perl_debug_log,
+                     "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv));
+       RESTORE_NUMERIC_LOCAL();
+    });
     return SvNVX(sv);
 }
 
@@ -1531,8 +1532,7 @@ S_asIV(pTHX_ SV *sv)
        if (ckWARN(WARN_NUMERIC))
            not_a_number(sv);
     }
-    SET_NUMERIC_STANDARD();
-    d = atof(SvPVX(sv));
+    d = Atof(SvPVX(sv));
     return I_V(d);
 }
 
@@ -1550,8 +1550,7 @@ S_asUV(pTHX_ SV *sv)
        if (ckWARN(WARN_NUMERIC))
            not_a_number(sv);
     }
-    SET_NUMERIC_STANDARD();
-    return U_V(atof(SvPVX(sv)));
+    return U_V(Atof(SvPVX(sv)));
 }
 
 /*
@@ -1601,11 +1600,12 @@ Perl_looks_like_number(pTHX_ SV *sv)
 
     nbegin = s;
     /*
-     * we return 1 if the number can be converted to _integer_ with atol()
-     * and 2 if you need (int)atof().
+     * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
+     * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
+     * (int)atof().
      */
 
-    /* next must be digit or '.' */
+    /* next must be digit or the radix separator */
     if (isDIGIT(*s)) {
         do {
            s++;
@@ -1616,17 +1616,25 @@ Perl_looks_like_number(pTHX_ SV *sv)
        else
            numtype |= IS_NUMBER_TO_INT_BY_ATOL;
 
-        if (*s == '.') {
+        if (*s == '.'
+#ifdef USE_LOCALE_NUMERIC 
+           || IS_NUMERIC_RADIX(*s)
+#endif
+           ) {
            s++;
            numtype |= IS_NUMBER_NOT_IV;
-            while (isDIGIT(*s))  /* optional digits after "." */
+            while (isDIGIT(*s))  /* optional digits after the radix */
                 s++;
         }
     }
-    else if (*s == '.') {
+    else if (*s == '.'
+#ifdef USE_LOCALE_NUMERIC 
+           || IS_NUMERIC_RADIX(*s)
+#endif
+           ) {
         s++;
        numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
-        /* no digits before '.' means we need digits after it */
+        /* no digits before the radix means we need digits after it */
         if (isDIGIT(*s)) {
            do {
                s++;
@@ -1725,7 +1733,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
            goto tokensave;
        }
        if (SvNOKp(sv)) {
-           SET_NUMERIC_STANDARD();
            Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
            tsv = Nullsv;
            goto tokensave;
@@ -1829,7 +1836,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
        if (SvREADONLY(sv)) {
            if (SvNOKp(sv)) {           /* See note in sv_2uv() */
                /* XXXX 64-bit?  IV may have better precision... */
-               SET_NUMERIC_STANDARD();
                Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
                tsv = Nullsv;
                goto tokensave;
@@ -1867,7 +1873,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
        else
 #endif /*apollo*/
        {
-           SET_NUMERIC_STANDARD();
            Gconvert(SvNVX(sv), DBL_DIG, 0, s);
        }
        errno = olderrno;
@@ -3766,8 +3771,7 @@ Perl_sv_inc(pTHX_ register SV *sv)
     while (isALPHA(*d)) d++;
     while (isDIGIT(*d)) d++;
     if (*d) {
-       SET_NUMERIC_STANDARD();
-       sv_setnv(sv,atof(SvPVX(sv)) + 1.0);  /* punt */
+       sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);  /* punt */
        return;
     }
     d--;
@@ -3866,8 +3870,7 @@ Perl_sv_dec(pTHX_ register SV *sv)
        (void)SvNOK_only(sv);
        return;
     }
-    SET_NUMERIC_STANDARD();
-    sv_setnv(sv,atof(SvPVX(sv)) - 1.0);        /* punt */
+    sv_setnv(sv,Atof(SvPVX(sv)) - 1.0);        /* punt */
 }
 
 /* Make a string that will exist for the duration of the expression
@@ -5086,7 +5089,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                *--eptr = '#';
            *--eptr = '%';
 
-           (void)sprintf(PL_efloatbuf, eptr, nv);
+           {
+               RESTORE_NUMERIC_STANDARD();
+               (void)sprintf(PL_efloatbuf, eptr, nv);
+               RESTORE_NUMERIC_LOCAL();
+           }
 
            eptr = PL_efloatbuf;
            elen = strlen(PL_efloatbuf);
index b53a228..760bc4b 100755 (executable)
@@ -21,23 +21,15 @@ eval {
     $have_setlocale++;
 };
 
-use vars qw(&LC_ALL);
-
 # 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;
 
-# 103 (the last test) may fail but that is sort-of okay.
-# (It indicates something broken in the environment, not Perl)
-
-print "1..", ($have_setlocale ? 103 : 98), "\n";
+print "1..", ($have_setlocale ? 114 : 98), "\n";
 
-use vars qw($a
-           $English $German $French $Spanish
-           @C @English @German @French @Spanish
-           $Locale @Locale %UPPER %lower %bothcase @Neoalpha);
+use vars qw(&LC_ALL);
 
-$a = 'abc %';
+my $a = 'abc %';
 
 sub ok {
     my ($n, $result) = @_;
@@ -236,7 +228,6 @@ Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW tw.EUC
 Croation:hr:hr:2
 Czech:cs:cz:2
 Danish:dk:da:1
-Danish:dk:da:1
 Dutch:nl:nl:1
 English American British:en:au ca gb ie nz us uk:1 cp850
 Estonian:et:ee:1
@@ -302,8 +293,12 @@ trylocale("C");
 trylocale("POSIX");
 foreach (0..15) {
     trylocale("ISO8859-$_");
-    trylocale("iso_8859_$_");
     trylocale("iso8859$_");
+    trylocale("iso8859-$_");
+    trylocale("iso_8859_$_");
+    trylocale("isolatin$_");
+    trylocale("isolatin-$_");
+    trylocale("iso_latin_$_");
 }
 
 foreach my $locale (split(/\n/, $locales)) {
@@ -350,6 +345,7 @@ sub debugf {
 debug "# Locales = @Locale\n";
 
 my %Problem;
+my @Neoalpha;
 
 foreach $Locale (@Locale) {
     debug "# Locale = $Locale\n";
@@ -365,7 +361,9 @@ foreach $Locale (@Locale) {
 
     # Sieve the uppercase and the lowercase.
     
-    %UPPER = %lower = %bothcase = ();
+    my %UPPER = ();
+    my %lower = ();
+    my %BoThCaSe = ();
     for (@Alnum_) {
        if (/[^\d_]/) { # skip digits and the _
            if (uc($_) eq $_) {
@@ -377,19 +375,19 @@ foreach $Locale (@Locale) {
        }
     }
     foreach (keys %UPPER) {
-       $bothcase{$_}++ if exists $lower{$_};
+       $BoThCaSe{$_}++ if exists $lower{$_};
     }
     foreach (keys %lower) {
-       $bothcase{$_}++ if exists $UPPER{$_};
+       $BoThCaSe{$_}++ if exists $UPPER{$_};
     }
-    foreach (keys %bothcase) {
+    foreach (keys %BoThCaSe) {
        delete $UPPER{$_};
        delete $lower{$_};
     }
 
     debug "# UPPER    = ", join(" ", sort keys %UPPER   ), "\n";
     debug "# lower    = ", join(" ", sort keys %lower   ), "\n";
-    debug "# bothcase = ", join(" ", sort keys %bothcase), "\n";
+    debug "# BoThCaSe = ", join(" ", sort keys %BoThCaSe), "\n";
 
     # Find the alphabets that are not alphabets in the default locale.
 
@@ -426,43 +424,33 @@ foreach $Locale (@Locale) {
        }
     }
 
-    # Test #100 removed but to preserve historical test number
-    # consistency we do not renumber the remaining tests.
-
     # Cross-check whole character set.
 
-    debug "# testing 101 with locale '$Locale'\n";
+    debug "# testing 100 with locale '$Locale'\n";
     for (map { chr } 0..255) {
        if ((/\w/ and /\W/) or (/\d/ and /\D/) or (/\s/ and /\S/)) {
-           $Problem{101}{$Locale} = 1;
-           debug "# failed 101\n";
+           $Problem{100}{$Locale} = 1;
+           debug "# failed 100\n";
            last;
        }
     }
 
     # Test for read-only scalars' locale vs non-locale comparisons.
 
-    debug "# testing 102 with locale '$Locale'\n";
+    debug "# testing 101 with locale '$Locale'\n";
     {
        no locale;
        $a = "qwerty";
        {
            use locale;
            if ($a cmp "qwerty") {
-               $Problem{102}{$Locale} = 1;
-               debug "# failed 102\n";
+               $Problem{101}{$Locale} = 1;
+               debug "# failed 101\n";
            }
        }
     }
 
-    # This test must be the last one because its failure is not fatal.
-    # The @Alnum_ should be internally consistent.
-    # Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no>
-    # for inventing a way to test for ordering consistency
-    # without requiring any particular order.
-    # <jhi@iki.fi>
-    
-    debug "# testing 103 with locale '$Locale'\n";
+    debug "# testing 102 with locale '$Locale'\n";
     {
        my ($from, $to, $lesser, $greater,
            @test, %test, $test, $yes, $no, $sign);
@@ -500,8 +488,8 @@ foreach $Locale (@Locale) {
            $test = 0;
            for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} }
            if ($test) {
-               $Problem{103}{$Locale} = 1;
-               debug "# failed 103 at:\n";
+               $Problem{102}{$Locale} = 1;
+               debug "# failed 102 at:\n";
                debug "# lesser  = '$lesser'\n";
                debug "# greater = '$greater'\n";
                debug "# lesser cmp greater = ", $lesser cmp $greater, "\n";
@@ -522,12 +510,10 @@ foreach $Locale (@Locale) {
     }
 }
 
-no locale;
-
-foreach (99..103) {
+foreach (99..102) {
     if ($Problem{$_}) {
-       if ($_ == 103) {
-           print "# The failure of test 103 is not necessarily fatal.\n";
+       if ($_ == 102) {
+           print "# The failure of test 102 is not necessarily fatal.\n";
            print "# It usually indicates a problem in the enviroment,\n";
            print "# not in Perl itself.\n";
        }
@@ -538,7 +524,7 @@ foreach (99..103) {
 
 my $didwarn = 0;
 
-foreach (99..103) {
+foreach (102..102) {
     if ($Problem{$_}) {
        my @f = sort keys %{ $Problem{$_} };
        my $f = join(" ", @f);
@@ -567,7 +553,7 @@ if ($didwarn) {
     
     foreach my $l (@Locale) {
        my $p = 0;
-       foreach my $t (99..103) {
+       foreach my $t (102..102) {
            $p++ if $Problem{$t}{$l};
        }
        push @s, $l if $p == 0;
@@ -582,4 +568,75 @@ if ($didwarn) {
        "# tested okay.\n#\n",
 }
 
+{
+    use locale;
+
+    my ($x, $y) = (1.23, 1.23);
+
+    my $a = "$x";
+    printf ''; # printf used to reset locale to "C"
+    my $b = "$y";
+
+    print "not " unless $a eq $b;
+    print "ok 103\n";
+
+    my $c = "$x";
+    my $z = sprintf ''; # sprintf used to reset locale to "C"
+    my $d = "$y";
+
+    print "not " unless $c eq $d;
+    print "ok 104\n";
+
+    my $w = 0;
+    local $SIG{__WARN__} = sub { $w++ };
+    local $^W = 1;
+
+    # the == (among other things) used to warn for locales
+    # that had something else than "." as the radix character
+
+    print "not " unless $c == 1.23;
+    print "ok 105\n";
+
+    print "not " unless $c == $x;
+    print "ok 106\n";
+
+    print "not " unless $c == $d;
+    print "ok 107\n";
+
+    debug "# 103..107: a = $a, b = $b, c = $c, d = $d\n";
+
+    {
+       no locale;
+       
+       my $e = "$x";
+
+       print "not " unless $e == 1.23;
+       print "ok 108\n";
+
+       print "not " unless $e == $x;
+       print "ok 109\n";
+
+       print "not " unless $e == $c;
+       print "ok 110\n";
+
+       debug "# 108..110: e = $e\n";
+    }
+
+    print "not " unless $w == 0;
+    print "ok 111\n";
+
+    my $f = "1.23";
+
+    print "not " unless $f == 1.23;
+    print "ok 112\n";
+
+    print "not " unless $f == $x;
+    print "ok 113\n";
+
+    print "not " unless $f == $c;
+    print "ok 114\n";
+
+    debug "# 112..114: f = $f\n";
+}
+
 # eof
diff --git a/toke.c b/toke.c
index 4b4e140..b025b24 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -6146,9 +6146,8 @@ Perl_scan_num(pTHX_ char *start)
 
        /* make an sv from the string */
        sv = NEWSV(92,0);
-       /* reset numeric locale in case we were earlier left in Swaziland */
-       SET_NUMERIC_STANDARD();
-       value = atof(PL_tokenbuf);
+
+       value = Atof(PL_tokenbuf);
 
        /* 
           See if we can make do with an integer value without loss of
diff --git a/util.c b/util.c
index 6755c48..381aece 100644 (file)
--- a/util.c
+++ b/util.c
 #  include <sys/wait.h>
 #endif
 
+#ifdef I_LOCALE
+#  include <locale.h>
+#endif
+
 #define FLUSH
 
 #ifdef LEAKTEST
@@ -536,6 +540,27 @@ Perl_new_collate(pTHX_ const char *newcoll)
 #endif /* USE_LOCALE_COLLATE */
 }
 
+void
+perl_set_numeric_radix(void)
+{
+#ifdef USE_LOCALE_NUMERIC
+# ifdef HAS_LOCALECONV
+    struct lconv* lc;
+
+    lc = localeconv();
+    if (lc && lc->decimal_point)
+       /* We assume that decimal separator aka the radix
+        * character is always a single character.  If it
+        * ever is a string, this needs to be rethunk. */
+       PL_numeric_radix = *lc->decimal_point;
+    else
+       PL_numeric_radix = 0;
+# endif /* HAS_LOCALECONV */
+#else
+    PL_numeric_radix = 0;
+#endif /* USE_LOCALE_NUMERIC */
+}
+
 /*
  * Set up for a new numeric locale.
  */
@@ -559,6 +584,7 @@ Perl_new_numeric(pTHX_ const char *newnum)
        PL_numeric_name = savepv(newnum);
        PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
        PL_numeric_local = TRUE;
+       perl_set_numeric_radix();
     }
 
 #endif /* USE_LOCALE_NUMERIC */
@@ -587,12 +613,12 @@ Perl_set_numeric_local(pTHX)
        setlocale(LC_NUMERIC, PL_numeric_name);
        PL_numeric_standard = FALSE;
        PL_numeric_local = TRUE;
+       perl_set_numeric_radix();
     }
 
 #endif /* USE_LOCALE_NUMERIC */
 }
 
-
 /*
  * Initialize locale awareness.
  */
@@ -3432,3 +3458,23 @@ Perl_my_fflush_all(pTHX)
     return EOF;
 #endif
 }
+
+double
+Perl_my_atof(const char* s) {
+#ifdef USE_LOCALE_NUMERIC
+    if (PL_numeric_local) {
+       double x, y;
+
+       x = atof(s);
+       SET_NUMERIC_STANDARD();
+       y = atof(s);
+       SET_NUMERIC_LOCAL();
+       if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
+           return y;
+       return x;
+    } else
+       return atof(s);
+#else
+    return atof(s);
+#endif
+}