/* 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
=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,
const char *d = s;
PERL_ARGS_ASSERT_PRESCAN_VERSION;
+ PERL_UNUSED_CONTEXT;
if (qv && isDIGIT(*d))
goto dotted_decimal_version;
/* 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;
*/
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)
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;
if ( !qv && s > start && saw_decimal == 1 ) {
mult *= 100;
while ( s < end ) {
+ if (*s == '_')
+ continue;
orev = rev;
rev += (*s - '0') * mult;
mult /= 10;
}
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;
}
}
}
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]) )
break;
}
if ( qv ) {
- while ( isDIGIT(*pos) )
+ while ( isDIGIT(*pos) || *pos == '_')
pos++;
}
else {
*/
SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_new_version2(pTHX_ SV *ver)
#else
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 */
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);
}
}
#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));
}
/*
*/
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)
const MAGIC *mg;
#endif
+#if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
ENTER;
+#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;
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);
+ }
+ }
+#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);
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);
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 */
+VER_PV:
{
STRLEN len;
version = savepvn(SvPV(ver,len), SvCUR(ver));
# 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 */
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Version string '%s' contains invalid data; "
"ignoring: '%s'", version, s);
+
+#if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
LEAVE;
+#endif
+
return ver;
}
*/
SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_vverify2(pTHX_ SV *vs)
#else
Perl_vverify(pTHX_ SV *vs)
*/
SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_vnumify2(pTHX_ SV *vs)
#else
Perl_vnumify(pTHX_ SV *vs)
{
SSize_t i, len;
I32 digit;
- int width;
bool alpha = FALSE;
SV *sv;
AV *av;
/* 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))) ) ) {
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;
*/
SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_vnormal2(pTHX_ SV *vs)
#else
Perl_vnormal(pTHX_ SV *vs)
#endif
{
I32 i, len, digit;
- bool alpha = FALSE;
SV *sv;
AV *av;
if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
- 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);
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");
*/
SV *
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_vstringify2(pTHX_ SV *vs)
#else
Perl_vstringify(pTHX_ SV *vs)
*/
int
-#if VUTIL_REPLACE_CORE
+#ifdef VUTIL_REPLACE_CORE
Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
#else
Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
{
SSize_t i,l,m,r;
I32 retval;
- bool lalpha = FALSE;
- bool ralpha = FALSE;
I32 left = 0;
I32 right = 0;
AV *lav, *rav;
/* get the left hand term */
lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
- if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
- lalpha = TRUE;
/* and the right hand term */
rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
- if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
- ralpha = TRUE;
l = av_len(lav);
r = av_len(rav);
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 )
}
return retval;
}
+
+/* ex: set ro: */