Create my_atof3()
authorKarl Williamson <khw@cpan.org>
Mon, 30 Apr 2018 16:46:01 +0000 (10:46 -0600)
committerKarl Williamson <khw@cpan.org>
Mon, 25 Jun 2018 13:33:26 +0000 (07:33 -0600)
This is like my_atof2(), but with an extra argument signifying the
length of the input string to parse.  If that length is 0, it uses
strlen() to determine it.

Then my_atof2() just calls my_atof3() with a zero final parameter.
And this commit just uses the bulk of the current my_atof2() as the core
of my_atof3().  Changes were needed however, because it relied on
NUL-termination in a number of places.

This allows one to convert a string that isn't necessarily
NUL-terminated to an NV.

embed.fnc
embed.h
numeric.c
perl.h
pod/perlclib.pod
proto.h

index 810bc93..7c606f4 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2909,7 +2909,8 @@ Apd       |char*  |sv_pvn_force_flags|NN SV *const sv|NULLOK STRLEN *const lp|const I32
 Apmb   |void   |sv_copypv      |NN SV *const dsv|NN SV *const ssv
 Apmd   |void   |sv_copypv_nomg |NN SV *const dsv|NN SV *const ssv
 Apd    |void   |sv_copypv_flags        |NN SV *const dsv|NN SV *const ssv|const I32 flags
-Ap     |char*  |my_atof2       |NN const char *orig|NN NV* value
+Apo    |char*  |my_atof2       |NN const char *orig|NN NV* value
+Ap     |char*  |my_atof3       |NN const char *orig|NN NV* value|const STRLEN len
 Apn    |int    |my_socketpair  |int family|int type|int protocol|int fd[2]
 Apn    |int    |my_dirfd       |NULLOK DIR* dir
 #ifdef PERL_ANY_COW
diff --git a/embed.h b/embed.h
index fb93ebc..9bc7fb3 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define mro_get_linear_isa(a)  Perl_mro_get_linear_isa(aTHX_ a)
 #define mro_method_changed_in(a)       Perl_mro_method_changed_in(aTHX_ a)
 #define my_atof(a)             Perl_my_atof(aTHX_ a)
-#define my_atof2(a,b)          Perl_my_atof2(aTHX_ a,b)
+#define my_atof3(a,b,c)                Perl_my_atof3(aTHX_ a,b,c)
 #define my_dirfd               Perl_my_dirfd
 #define my_exit(a)             Perl_my_exit(aTHX_ a)
 #define my_failure_exit()      Perl_my_failure_exit(aTHX)
index 8754a9f..99531ef 100644 (file)
--- a/numeric.c
+++ b/numeric.c
@@ -1228,7 +1228,7 @@ Perl_my_atof(pTHX_ const char* s)
 
 #ifdef USE_QUADMATH
 
-    Perl_my_atof2(aTHX_ s, &x);
+    my_atof2(s, &x);
 
 #elif ! defined(USE_LOCALE_NUMERIC)
 
@@ -1366,11 +1366,20 @@ S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value
 
 char*
 Perl_my_atof2(pTHX_ const char* orig, NV* value)
+{
+    PERL_ARGS_ASSERT_MY_ATOF2;
+    return my_atof3(orig, value, 0);
+}
+
+char*
+Perl_my_atof3(pTHX_ const char* orig, NV* value, STRLEN len)
 {
     const char* s = orig;
     NV result[3] = {0.0, 0.0, 0.0};
 #if defined(USE_PERL_ATOF) || defined(USE_QUADMATH)
-    const char* send = s + strlen(orig); /* one past the last */
+    const char* send = s + ((len != 0)
+                           ? len
+                           : strlen(orig)); /* one past the last */
     bool negative = 0;
 #endif
 #if defined(USE_PERL_ATOF) && !defined(USE_QUADMATH)
@@ -1387,10 +1396,10 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
 #endif
 
 #if defined(USE_PERL_ATOF) || defined(USE_QUADMATH)
-    PERL_ARGS_ASSERT_MY_ATOF2;
+    PERL_ARGS_ASSERT_MY_ATOF3;
 
     /* leading whitespace */
-    while (isSPACE(*s))
+    while (s < send && isSPACE(*s))
        ++s;
 
     /* sign */
@@ -1408,6 +1417,7 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
         char* endp;
         if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
             return endp;
+        endp = send;
         result[2] = strtoflt128(s, &endp);
         if (s != endp) {
             *value = negative ? -result[2] : result[2];
@@ -1457,7 +1467,7 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
     /* we accumulate digits into an integer; when this becomes too
      * large, we add the total to NV and start again */
 
-    while (1) {
+    while (s < send) {
        if (isDIGIT(*s)) {
            seen_digit = 1;
            old_digit = digit;
@@ -1485,7 +1495,7 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
                    exp_adjust[0]++;
                }
                /* skip remaining digits */
-               while (isDIGIT(*s)) {
+               while (s < send && isDIGIT(*s)) {
                    ++s;
                    if (! seen_dp) {
                        exp_adjust[0]++;
@@ -1509,7 +1519,7 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
        else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
            seen_dp = 1;
            if (sig_digits > MAX_SIG_DIGITS) {
-               while (isDIGIT(*s)) {
+               while (s < send && isDIGIT(*s)) {
                    ++s;
                }
                break;
@@ -1525,7 +1535,7 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
        result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
     }
 
-    if (seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) {
+    if (s < send && seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) {
        bool expnegative = 0;
 
        ++s;
@@ -1536,14 +1546,12 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
            case '+':
                ++s;
        }
-       while (isDIGIT(*s))
+       while (s < send && isDIGIT(*s))
            exponent = exponent * 10 + (*s++ - '0');
        if (expnegative)
            exponent = -exponent;
     }
 
-
-
     /* now apply the exponent */
 
     if (seen_dp) {
diff --git a/perl.h b/perl.h
index 30f9973..6f04c6f 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2328,11 +2328,12 @@ int isnan(double d);
 
 #ifdef USE_PERL_ATOF
 #   define Perl_atof(s) Perl_my_atof(s)
-#   define Perl_atof2(s, n) Perl_my_atof2(aTHX_ (s), &(n))
+#   define Perl_atof2(s, n) Perl_my_atof3(aTHX_ (s), &(n), 0)
 #else
 #   define Perl_atof(s) (NV)atof(s)
 #   define Perl_atof2(s, n) ((n) = atof(s))
 #endif
+#define my_atof2(a,b) my_atof3(a,b,0)
 
 /*
  * CHAR_MIN and CHAR_MAX are not included here, as the (char) type may be
index b366c7f..1e6cf77 100644 (file)
@@ -205,7 +205,7 @@ C<toUPPER_uni>, as described in L<perlapi/Character case changing>.)
  atof(s)                     Atof(s)
  atoi(s)                     grok_atoUV(s, &uv, &e)
  atol(s)                     grok_atoUV(s, &uv, &e)
- strtod(s, &p)               Nothing.  Just don't use it.
+ strtod(s, &p)               my_atof3(s, &nv, &p) is the closest we have
  strtol(s, &p, n)            grok_atoUV(s, &uv, &e)
  strtoul(s, &p, n)           grok_atoUV(s, &uv, &e)
 
diff --git a/proto.h b/proto.h
index 818acd9..7be8fbd 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2220,6 +2220,9 @@ PERL_CALLCONV NV  Perl_my_atof(pTHX_ const char *s);
 PERL_CALLCONV char*    Perl_my_atof2(pTHX_ const char *orig, NV* value);
 #define PERL_ARGS_ASSERT_MY_ATOF2      \
        assert(orig); assert(value)
+PERL_CALLCONV char*    Perl_my_atof3(pTHX_ const char *orig, NV* value, const STRLEN len);
+#define PERL_ARGS_ASSERT_MY_ATOF3      \
+       assert(orig); assert(value)
 PERL_CALLCONV OP *     Perl_my_attrs(pTHX_ OP *o, OP *attrs);
 #define PERL_ARGS_ASSERT_MY_ATTRS      \
        assert(o)