}
}
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))
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));
#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
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
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
#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
Perl_mod
Perl_moreswitches
Perl_my
+Perl_my_atof
Perl_my_bcopy
Perl_my_bzero
Perl_my_exit
Perl_new_ctype
Perl_new_numeric
Perl_set_numeric_local
+Perl_set_numeric_radix
Perl_set_numeric_standard
perl_parse
Perl_require_pv
/* Assume simple numerics */
PERLVARI(Inumeric_local, bool, TRUE)
/* Assume local numerics */
+PERLVAR(Inumeric_radix, char)
+ /* The radix character if not '.' */
#endif /* !USE_LOCALE_NUMERIC */
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;
++p;
if (!*p)
break;
- gary[i] = I_V(atof(p));
+ gary[i] = I_V(atol(p));
}
if (i)
(void)setgroups(i, gary);
#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
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;
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 */
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);
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);
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;
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;
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);
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;
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;
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
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);
* - 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);
* - 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);
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))
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))
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);
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;
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);
}
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- SET_NUMERIC_STANDARD();
- d = atof(SvPVX(sv));
+ d = Atof(SvPVX(sv));
return I_V(d);
}
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- SET_NUMERIC_STANDARD();
- return U_V(atof(SvPVX(sv)));
+ return U_V(Atof(SvPVX(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++;
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++;
goto tokensave;
}
if (SvNOKp(sv)) {
- SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
tsv = Nullsv;
goto tokensave;
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;
else
#endif /*apollo*/
{
- SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, s);
}
errno = olderrno;
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--;
(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
*--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);
$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) = @_;
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
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)) {
debug "# Locales = @Locale\n";
my %Problem;
+my @Neoalpha;
foreach $Locale (@Locale) {
debug "# Locale = $Locale\n";
# 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 $_) {
}
}
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.
}
}
- # 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);
$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";
}
}
-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";
}
my $didwarn = 0;
-foreach (99..103) {
+foreach (102..102) {
if ($Problem{$_}) {
my @f = sort keys %{ $Problem{$_} };
my $f = join(" ", @f);
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;
"# 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
/* 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
# include <sys/wait.h>
#endif
+#ifdef I_LOCALE
+# include <locale.h>
+#endif
+
#define FLUSH
#ifdef LEAKTEST
#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.
*/
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 */
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.
*/
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
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff