regexec.c: Move a #define next to related code

[perl5.git] / vutil.c

diff --git a/vutil.c b/vutil.c
index 4cf0173..20fb522 100644 (file)
--- a/vutil.c
+++ b/vutil.c
@@ -18,6 +18,8 @@
 #define VERSION_MAX 0x7FFFFFFF
 
 /*
+=head1 Versioning
+
 =for apidoc prescan_version
 
 Validate that a given string can be parsed as a version object, but doesn't
@@ -28,7 +30,7 @@ some time when tokenizing.
 =cut
 */
 const char *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
 Perl_prescan_version2(pTHX_ const char *s, bool strict,
 #else
 Perl_prescan_version(pTHX_ const char *s, bool strict,
@@ -259,7 +261,7 @@ it doesn't.
 */
 
 const char *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
 Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv)
 #else
 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
@@ -453,7 +455,7 @@ want to upgrade the SV.
 */
 
 SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
 Perl_new_version2(pTHX_ SV *ver)
 #else
 Perl_new_version(pTHX_ SV *ver)
@@ -525,7 +527,8 @@ Perl_new_version(pTHX_ SV *ver)
        }
     }
 #endif
-    return UPG_VERSION(rv, FALSE);
+    sv_2mortal(rv); /* in case upg_version croaks before it returns */
+    return SvREFCNT_inc_NN(UPG_VERSION(rv, FALSE));
 }
 
 /*
@@ -542,7 +545,7 @@ to force this SV to be interpreted as an "extended" version.
 */
 
 SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
 Perl_upg_version2(pTHX_ SV *ver, bool qv)
 #else
 Perl_upg_version(pTHX_ SV *ver, bool qv)
@@ -558,7 +561,29 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 #endif
     PERL_ARGS_ASSERT_UPG_VERSION;
 
-    if ( SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
+    if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
+          || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
+       /* out of bounds [unsigned] integer */
+       STRLEN len;
+       char tbuf[64];
+       len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
+       version = savepvn(tbuf, len);
+       SAVEFREEPV(version);
+       Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+                      "Integer overflow in version %d",VERSION_MAX);
+    }
+    else if ( SvUOK(ver) || SvIOK(ver))
+#if PERL_VERSION_LT(5,17,2)
+VER_IV:
+#endif
+    {
+       version = savesvpv(ver);
+       SAVEFREEPV(version);
+    }
+    else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
+#if PERL_VERSION_LT(5,17,2)
+VER_NV:
+#endif
     {
        STRLEN len;
 
@@ -566,7 +591,39 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
        char tbuf[64];
        SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
        char *buf;
+#ifdef USE_LOCALE_NUMERIC
+        const char * const cur_numeric = setlocale(LC_NUMERIC, NULL);
+        assert(cur_numeric);
+
+        /* XS code can set the locale without us knowing.  To protect the
+         * version number parsing, which requires the radix character to be a
+         * dot, update our records as to what the locale is, so that our
+         * existing macro mechanism can correctly change it to a dot and back
+         * if necessary.  This code is extremely unlikely to be in a loop, so
+         * the extra work will have a negligible performance impact.  See [perl
+         * #121930].
+         *
+         * If the current locale is a standard one, but we are expecting it to
+         * be a different, underlying locale, update our records to make the
+         * underlying locale this (standard) one.  If the current locale is not
+         * a standard one, we should be expecting a non-standard one, the same
+         * one that we have recorded as the underlying locale.  If not, update
+         * our records. */
+        if (strEQ(cur_numeric, "C") || strEQ(cur_numeric, "POSIX")) {
+            if (! PL_numeric_standard) {
+                new_numeric(cur_numeric);
+            }
+        }
+        else if (PL_numeric_standard
+                 || ! PL_numeric_name
+                 || strNE(PL_numeric_name, cur_numeric))
+        {
+            new_numeric(cur_numeric);
+        }
+#endif
+        { /* Braces needed because macro just below declares a variable */
         STORE_NUMERIC_LOCAL_SET_STANDARD();
+        LOCK_NUMERIC_STANDARD();
        if (sv) {
            Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
            len = SvCUR(sv);
@@ -576,7 +633,9 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
            len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
            buf = tbuf;
        }
+        UNLOCK_NUMERIC_STANDARD();
         RESTORE_NUMERIC_LOCAL();
+        }
        while (buf[len-1] == '0' && len > 0) len--;
        if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
        version = savepvn(buf, len);
@@ -590,22 +649,10 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
        qv = TRUE;
     }
 #endif
-    else if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
-          || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
-       /* out of bounds [unsigned] integer */
-       STRLEN len;
-       char tbuf[64];
-       len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
-       version = savepvn(tbuf, len);
-       SAVEFREEPV(version);
-       Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
-                      "Integer overflow in version %d",VERSION_MAX);
-    }
-    else if ( SvUOK(ver) || SvIOK(ver) ) {
-       version = savesvpv(ver);
-       SAVEFREEPV(version);
-    }
-    else if ( SvPOK(ver) )/* must be a string or something like a string */
+    else if ( SvPOK(ver))/* must be a string or something like a string */
+#if PERL_VERSION_LT(5,17,2)
+VER_PV:
+#endif
     {
        STRLEN len;
        version = savepvn(SvPV(ver,len), SvCUR(ver));
@@ -647,6 +694,17 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 #  endif
 #endif
     }
+#if PERL_VERSION_LT(5,17,2)
+    else if (SvIOKp(ver)) {
+       goto VER_IV;
+    }
+    else if (SvNOKp(ver)) {
+       goto VER_NV;
+    }
+    else if (SvPOKp(ver)) {
+       goto VER_PV;
+    }
+#endif
     else
     {
        /* no idea what this is */
@@ -662,6 +720,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
     LEAVE;
 #endif
+
     return ver;
 }
 
@@ -692,7 +751,7 @@ confused by derived classes which may contain additional hash entries):
 */
 
 SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
 Perl_vverify2(pTHX_ SV *vs)
 #else
 Perl_vverify(pTHX_ SV *vs)
@@ -733,7 +792,7 @@ The SV returned has a refcount of 1.
 */
 
 SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
 Perl_vnumify2(pTHX_ SV *vs)
 #else
 Perl_vnumify(pTHX_ SV *vs)
@@ -827,7 +886,7 @@ The SV returned has a refcount of 1.
 */
 
 SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
 Perl_vnormal2(pTHX_ SV *vs)
 #else
 Perl_vnormal(pTHX_ SV *vs)
@@ -897,7 +956,7 @@ The SV returned has a refcount of 1.
 */
 
 SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
 Perl_vstringify2(pTHX_ SV *vs)
 #else
 Perl_vstringify(pTHX_ SV *vs)
@@ -938,7 +997,7 @@ converted into version objects.
 */
 
 int
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
 #else
 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)