diff options
| -rw-r--r-- | dump.c | 6 | ||||
| -rw-r--r-- | embed.h | 12 | ||||
| -rwxr-xr-x | embed.pl | 4 | ||||
| -rw-r--r-- | embedvar.h | 2 | ||||
| -rw-r--r-- | global.sym | 2 | ||||
| -rw-r--r-- | intrpvar.h | 2 | ||||
| -rw-r--r-- | mg.c | 5 | ||||
| -rw-r--r-- | objXSUB.h | 8 | ||||
| -rw-r--r-- | perl.c | 2 | ||||
| -rw-r--r-- | perl.h | 16 | ||||
| -rw-r--r-- | pp.c | 10 | ||||
| -rw-r--r-- | pp_ctl.c | 20 | ||||
| -rw-r--r-- | pp_sys.c | 6 | ||||
| -rw-r--r-- | proto.h | 4 | ||||
| -rw-r--r-- | sv.c | 77 | ||||
| -rwxr-xr-x | t/pragma/locale.t | 145 | ||||
| -rw-r--r-- | toke.c | 5 | ||||
| -rw-r--r-- | util.c | 48 |
18 files changed, 261 insertions, 113 deletions
@@ -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)); @@ -311,6 +311,9 @@ #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 @@ -423,6 +426,7 @@ #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 @@ -1612,6 +1616,9 @@ #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 @@ -1723,6 +1730,7 @@ #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) @@ -2917,6 +2925,9 @@ #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 @@ -3029,6 +3040,7 @@ #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 @@ -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 diff --git a/embedvar.h b/embedvar.h index 1312258714..dbd94e9c51 100644 --- a/embedvar.h +++ b/embedvar.h @@ -428,6 +428,7 @@ #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) @@ -684,6 +685,7 @@ #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 diff --git a/global.sym b/global.sym index f3e6494355..0c3f72bca7 100644 --- a/global.sym +++ b/global.sym @@ -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 diff --git a/intrpvar.h b/intrpvar.h index 744ff31450..0bf826e79a 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -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 */ @@ -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); @@ -406,6 +406,8 @@ #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 @@ -1361,6 +1363,10 @@ #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 @@ -1571,6 +1577,8 @@ #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 @@ -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; @@ -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 */ @@ -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; @@ -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; @@ -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; @@ -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); @@ -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); diff --git a/t/pragma/locale.t b/t/pragma/locale.t index b53a22809a..760bc4b589 100755 --- a/t/pragma/locale.t +++ b/t/pragma/locale.t @@ -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 @@ -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 @@ -51,6 +51,10 @@ # 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 +} |