Import version.pm 0.9914 from CPAN

1 files changed, 93 insertions, 107 deletions

diff --git a/vutil.c b/vutil.c
index 20fb522ee5..e43d2b2788 100644
--- a/vutil.c
+++ b/vutil.c
@@ -1,25 +1,13 @@
 /* This file is part of the "version" CPAN distribution.  Please avoid
    editing it in the perl core. */
 
-#ifndef PERL_CORE
-#  define PERL_NO_GET_CONTEXT
-#  include "EXTERN.h"
-#  include "perl.h"
-#  include "XSUB.h"
-#  define NEED_my_snprintf
-#  define NEED_newRV_noinc
-#  define NEED_vnewSVpvf
-#  define NEED_newSVpvn_flags_GLOBAL
-#  define NEED_warner
-#  include "ppport.h"
+#ifdef PERL_CORE
+#  include "vutil.h"
 #endif
-#include "vutil.h"
 
 #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
@@ -43,7 +31,7 @@ Perl_prescan_version(pTHX_ const char *s, bool strict,
     bool alpha = FALSE;
     const char *d = s;
 
-    PERL_ARGS_ASSERT_PRESCAN_VERSION;
+    PERL_ARGS_ASSERT_PRESCAN_VERSION; PERL_UNUSED_CONTEXT;
 
     if (qv && isDIGIT(*d))
 	goto dotted_decimal_version;
@@ -226,6 +214,11 @@ version_prescan_finish:
 	/* trailing non-numeric data */
 	BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
     }
+    if (saw_decimal > 1 && d[-1] == '.') {
+	/* no trailing period allowed */
+	BADVERSION(s,errstr,"Invalid version format (trailing decimal)");
+    }
+
 
     if (sqv)
 	*sqv = qv;
@@ -312,7 +305,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     if ( !qv && width < 3 )
 	(void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
 
-    while (isDIGIT(*pos))
+    while (isDIGIT(*pos) || *pos == '_')
 	pos++;
     if (!isALPHA(*pos)) {
 	I32 rev;
@@ -332,6 +325,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 		if ( !qv && s > start && saw_decimal == 1 ) {
 		    mult *= 100;
  		    while ( s < end ) {
+			if (*s == '_')
+			    continue;
 			orev = rev;
  			rev += (*s - '0') * mult;
  			mult /= 10;
@@ -350,17 +345,27 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
   		}
  		else {
  		    while (--end >= s) {
-			orev = rev;
- 			rev += (*end - '0') * mult;
- 			mult *= 10;
-			if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
-			    || (PERL_ABS(rev) > VERSION_MAX )) {
+			int i;
+			if (*end == '_')
+			    continue;
+			i = (*end - '0');
+                        if (   (mult == VERSION_MAX)
+                            || (i > VERSION_MAX / mult)
+                            || (i * mult > VERSION_MAX - rev))
+                        {
 			    Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
 					   "Integer overflow in version");
 			    end = s - 1;
 			    rev = VERSION_MAX;
 			    vinf = 1;
 			}
+                        else
+                            rev += i * mult;
+
+                        if (mult > VERSION_MAX / 10)
+                            mult = VERSION_MAX;
+                        else
+                            mult *= 10;
  		    }
  		} 
   	    }
@@ -371,8 +376,14 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 		s = last;
 		break;
 	    }
-	    else if ( *pos == '.' )
-		s = ++pos;
+	    else if ( *pos == '.' ) {
+		pos++;
+		if (qv) {
+		    while (*pos == '0')
+			++pos;
+		}
+		s = pos;
+	    }
 	    else if ( *pos == '_' && isDIGIT(pos[1]) )
 		s = ++pos;
 	    else if ( *pos == ',' && isDIGIT(pos[1]) )
@@ -384,7 +395,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 		break;
 	    }
 	    if ( qv ) {
-		while ( isDIGIT(*pos) )
+		while ( isDIGIT(*pos) || *pos == '_')
 		    pos++;
 	    }
 	    else {
@@ -461,7 +472,6 @@ Perl_new_version2(pTHX_ SV *ver)
 Perl_new_version(pTHX_ SV *ver)
 #endif
 {
-    dVAR;
     SV * const rv = newSV(0);
     PERL_ARGS_ASSERT_NEW_VERSION;
     if ( ISA_VERSION_OBJ(ver) ) /* can just copy directly */
@@ -515,7 +525,16 @@ Perl_new_version(pTHX_ SV *ver)
 	if ( mg ) { /* already a v-string */
 	    const STRLEN len = mg->mg_len;
 	    const char * const version = (const char*)mg->mg_ptr;
+	    char *raw, *under;
+	    static const char underscore[] = "_";
 	    sv_setpvn(rv,version,len);
+	    raw = SvPV_nolen(rv);
+	    under = ninstr(raw, raw+len, underscore, underscore + 1);
+	    if (under) {
+		Move(under + 1, under, raw + len - under - 1, char);
+		SvCUR(rv)--;
+		*SvEND(rv) = '\0';
+	    }
 	    /* this is for consistency with the pure Perl class */
 	    if ( isDIGIT(*version) )
 		sv_insert(rv, 0, 0, "v", 1);
@@ -591,35 +610,45 @@ VER_NV:
 	char tbuf[64];
 	SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
 	char *buf;
+
+#if PERL_VERSION_GE(5,19,0)
+	if (SvPOK(ver)) {
+	    /* dualvar? */
+	    goto VER_PV;
+	}
+#endif
+
 #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);
-        }
+	{
+	    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();
@@ -650,9 +679,7 @@ VER_NV:
     }
 #endif
     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));
@@ -800,7 +827,6 @@ Perl_vnumify(pTHX_ SV *vs)
 {
     SSize_t i, len;
     I32 digit;
-    int width;
     bool alpha = FALSE;
     SV *sv;
     AV *av;
@@ -815,14 +841,11 @@ Perl_vnumify(pTHX_ SV *vs)
     /* see if various flags exist */
     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
 	alpha = TRUE;
-    {
-	SV ** svp = hv_fetchs(MUTABLE_HV(vs), "width", FALSE);
-	if ( svp )
-	    width = SvIV(*svp);
-	else
-	    width = 3;
-    }
 
+    if (alpha) {
+	Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
+		       "alpha->numify() is lossy");
+    }
 
     /* attempt to retrieve the version array */
     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
@@ -840,30 +863,14 @@ Perl_vnumify(pTHX_ SV *vs)
 	digit = SvIV(tsv);
     }
     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
-    for ( i = 1 ; i < len ; i++ )
+    for ( i = 1 ; i <= len ; i++ )
     {
 	SV * tsv = *av_fetch(av, i, 0);
 	digit = SvIV(tsv);
-	if ( width < 3 ) {
-	    const int denom = (width == 2 ? 10 : 100);
-	    const div_t term = div((int)PERL_ABS(digit),denom);
-	    Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
-	}
-	else {
-	    Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
-	}
+	Perl_sv_catpvf(aTHX_ sv, "%03d", (int)digit);
     }
 
-    if ( len > 0 )
-    {
-	SV * tsv = *av_fetch(av, len, 0);
-	digit = SvIV(tsv);
-	if ( alpha && width == 3 ) /* alpha version */
-	    sv_catpvs(sv,"_");
-	Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
-    }
-    else /* len == 0 */
-    {
+    if ( len == 0 ) {
 	sv_catpvs(sv, "000");
     }
     return sv;
@@ -906,6 +913,7 @@ Perl_vnormal(pTHX_ SV *vs)
 
     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
 	alpha = TRUE;
+
     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
 
     len = av_len(av);
@@ -918,23 +926,12 @@ Perl_vnormal(pTHX_ SV *vs)
 	digit = SvIV(tsv);
     }
     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
-    for ( i = 1 ; i < len ; i++ ) {
+    for ( i = 1 ; i <= len ; i++ ) {
 	SV * tsv = *av_fetch(av, i, 0);
 	digit = SvIV(tsv);
 	Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
     }
 
-    if ( len > 0 )
-    {
-	/* handle last digit specially */
-	SV * tsv = *av_fetch(av, len, 0);
-	digit = SvIV(tsv);
-	if ( alpha )
-	    Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
-	else
-	    Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
-    }
-
     if ( len <= 2 ) { /* short version, must be at least three */
 	for ( len = 2 - len; len != 0; len-- )
 	    sv_catpvs(sv,".0");
@@ -1048,19 +1045,6 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
 	i++;
     }
 
-    /* tiebreaker for alpha with identical terms */
-    if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
-    {
-	if ( lalpha && !ralpha )
-	{
-	    retval = -1;
-	}
-	else if ( ralpha && !lalpha)
-	{
-	    retval = +1;
-	}
-    }
-
     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
     {
 	if ( l < r )
@@ -1086,3 +1070,5 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
     }
     return retval;
 }
+
+/* ex: set ro: */