summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--embed.h4
-rwxr-xr-xembed.pl1
-rw-r--r--global.sym1
-rw-r--r--objXSUB.h4
-rw-r--r--perl.h20
-rw-r--r--perlapi.c7
-rw-r--r--proto.h1
-rw-r--r--util.c75
8 files changed, 91 insertions, 22 deletions
diff --git a/embed.h b/embed.h
index 1a2f0e0d71..dd0097c438 100644
--- a/embed.h
+++ b/embed.h
@@ -1178,6 +1178,7 @@
#define sv_utf8_upgrade_flags Perl_sv_utf8_upgrade_flags
#define sv_pvn_force_flags Perl_sv_pvn_force_flags
#define sv_2pv_flags Perl_sv_2pv_flags
+#define my_atof2 Perl_my_atof2
#define ck_anoncode Perl_ck_anoncode
#define ck_bitop Perl_ck_bitop
#define ck_concat Perl_ck_concat
@@ -2667,6 +2668,7 @@
#define sv_utf8_upgrade_flags(a,b) Perl_sv_utf8_upgrade_flags(aTHX_ a,b)
#define sv_pvn_force_flags(a,b,c) Perl_sv_pvn_force_flags(aTHX_ a,b,c)
#define sv_2pv_flags(a,b,c) Perl_sv_2pv_flags(aTHX_ a,b,c)
+#define my_atof2(a,b) Perl_my_atof2(aTHX_ a,b)
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
#define ck_concat(a) Perl_ck_concat(aTHX_ a)
@@ -5186,6 +5188,8 @@
#define sv_pvn_force_flags Perl_sv_pvn_force_flags
#define Perl_sv_2pv_flags CPerlObj::Perl_sv_2pv_flags
#define sv_2pv_flags Perl_sv_2pv_flags
+#define Perl_my_atof2 CPerlObj::Perl_my_atof2
+#define my_atof2 Perl_my_atof2
#define Perl_ck_anoncode CPerlObj::Perl_ck_anoncode
#define ck_anoncode Perl_ck_anoncode
#define Perl_ck_bitop CPerlObj::Perl_ck_bitop
diff --git a/embed.pl b/embed.pl
index 139270b47b..7c251bb617 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2594,3 +2594,4 @@ Apd |void |sv_catsv_flags |SV* dsv|SV* ssv|I32 flags
Apd |STRLEN |sv_utf8_upgrade_flags|SV *sv|I32 flags
Apd |char* |sv_pvn_force_flags|SV* sv|STRLEN* lp|I32 flags
Ap |char* |sv_2pv_flags |SV* sv|STRLEN* lp|I32 flags
+Ap |char* |my_atof2 |const char *s|NV* value
diff --git a/global.sym b/global.sym
index 544e1cfc25..b8bfb2c1ad 100644
--- a/global.sym
+++ b/global.sym
@@ -579,3 +579,4 @@ Perl_sv_catsv_flags
Perl_sv_utf8_upgrade_flags
Perl_sv_pvn_force_flags
Perl_sv_2pv_flags
+Perl_my_atof2
diff --git a/objXSUB.h b/objXSUB.h
index a3cb92cae2..d3ca5272b7 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -2414,6 +2414,10 @@
#define Perl_sv_2pv_flags pPerl->Perl_sv_2pv_flags
#undef sv_2pv_flags
#define sv_2pv_flags Perl_sv_2pv_flags
+#undef Perl_my_atof2
+#define Perl_my_atof2 pPerl->Perl_my_atof2
+#undef my_atof2
+#define my_atof2 Perl_my_atof2
#endif /* PERL_CORE && PERL_OBJECT */
#endif /* __objXSUB_h__ */
diff --git a/perl.h b/perl.h
index 88d32a4852..45614676f7 100644
--- a/perl.h
+++ b/perl.h
@@ -1311,24 +1311,8 @@ typedef NVTYPE NV;
# endif
#endif
-#if !defined(Perl_atof) && defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
-# if !defined(Perl_atof) && defined(HAS_STRTOLD)
-# define Perl_atof(s) (NV)strtold(s, (char**)NULL)
-# endif
-# if !defined(Perl_atof) && defined(HAS_ATOLF)
-# define Perl_atof (NV)atolf
-# endif
-# if !defined(Perl_atof) && defined(PERL_SCNfldbl)
-# define Perl_atof PERL_SCNfldbl
-# define Perl_atof2(s,f) sscanf((s), "%"PERL_SCNfldbl, &(f))
-# endif
-#endif
-#if !defined(Perl_atof)
-# define Perl_atof atof /* we assume atof being available anywhere */
-#endif
-#if !defined(Perl_atof2)
-# define Perl_atof2(s,f) ((f) = (NV)Perl_atof(s))
-#endif
+#define Perl_atof(s) Perl_my_atof(s)
+#define Perl_atof2(s, np) Perl_my_atof2(s, np)
/* Previously these definitions used hardcoded figures.
* It is hoped these formula are more portable, although
diff --git a/perlapi.c b/perlapi.c
index b8ec2c5c68..a04ab223cf 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -4289,6 +4289,13 @@ Perl_sv_2pv_flags(pTHXo_ SV* sv, STRLEN* lp, I32 flags)
return ((CPerlObj*)pPerl)->Perl_sv_2pv_flags(sv, lp, flags);
}
+#undef Perl_my_atof2
+char*
+Perl_my_atof2(pTHXo_ const char *s, NV* value)
+{
+ return ((CPerlObj*)pPerl)->Perl_my_atof2(s, value);
+}
+
#undef Perl_fprintf_nocontext
int
Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
diff --git a/proto.h b/proto.h
index 5104261810..9a5cdfb961 100644
--- a/proto.h
+++ b/proto.h
@@ -1314,3 +1314,4 @@ PERL_CALLCONV void Perl_sv_catsv_flags(pTHX_ SV* dsv, SV* ssv, I32 flags);
PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade_flags(pTHX_ SV *sv, I32 flags);
PERL_CALLCONV char* Perl_sv_pvn_force_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags);
PERL_CALLCONV char* Perl_sv_2pv_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags);
+PERL_CALLCONV char* Perl_my_atof2(pTHX_ const char *s, NV* value);
diff --git a/util.c b/util.c
index 6a01a4665a..9b6795b690 100644
--- a/util.c
+++ b/util.c
@@ -4018,21 +4018,88 @@ Perl_my_atof(pTHX_ const char* s)
if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
NV y;
- Perl_atof2(s, x);
+ Perl_atof2(s, &x);
SET_NUMERIC_STANDARD();
- Perl_atof2(s, y);
+ Perl_atof2(s, &y);
SET_NUMERIC_LOCAL();
if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
return y;
}
else
- Perl_atof2(s, x);
+ Perl_atof2(s, &x);
#else
- Perl_atof2(s, x);
+ Perl_atof2(s, &x);
#endif
return x;
}
+char*
+Perl_my_atof2(pTHX_ const char* orig, NV* value)
+{
+ NV result = 0.0;
+ bool negative = 0;
+ char* s = (char*)orig;
+ char* point = "."; /* locale-dependent decimal point equivalent */
+ STRLEN pointlen = 1;
+ bool seendigit = 0;
+
+ if (PL_numeric_radix_sv)
+ point = SvPV(PL_numeric_radix_sv, pointlen);
+
+ switch (*s) {
+ case '-':
+ negative = 1;
+ /* fall through */
+ case '+':
+ ++s;
+ }
+ while (isDIGIT(*s)) {
+ result = result * 10 + (*s++ - '0');
+ seendigit = 1;
+ }
+ if (memEQ(s, point, pointlen)) {
+ NV decimal = 0.1;
+
+ s += pointlen;
+ while (isDIGIT(*s)) {
+ result += (*s++ - '0') * decimal;
+ decimal *= 0.1;
+ seendigit = 1;
+ }
+ }
+ if (seendigit && (*s == 'e' || *s == 'E')) {
+ I32 exponent = 0;
+ I32 expnegative = 0;
+ I32 bit;
+ NV power;
+
+ ++s;
+ switch (*s) {
+ case '-':
+ expnegative = 1;
+ /* fall through */
+ case '+':
+ ++s;
+ }
+ while (isDIGIT(*s))
+ exponent = exponent * 10 + (*s++ - '0');
+
+ /* now apply the exponent */
+ power = (expnegative) ? 0.1 : 10.0;
+ for (bit = 1; exponent; bit <<= 1) {
+ if (exponent & bit) {
+ exponent ^= bit;
+ result *= power;
+ }
+ power *= power;
+ }
+ }
+ if (negative)
+ result = -result;
+ *value = result;
+ return s;
+}
+
void
Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
{