/* This file is part of the "version" CPAN distribution. Please avoid
editing it in the perl core. */
-#ifndef PERL_CORE
-# 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)
last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
if (errstr) {
/* "undef" is a special case and not an error */
- if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
- Safefree(start);
+ if ( ! ( *s == 'u' && strEQ(s+1,"ndef")) ) {
Perl_croak(aTHX_ "%s", errstr);
}
}
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 {
}
}
if ( qv ) { /* quoted versions always get at least three terms*/
- SSize_t len = av_len(av);
+ SSize_t len = AvFILLp(av);
/* This for loop appears to trigger a compiler bug on OS X, as it
loops infinitely. Yes, len is negative. No, it makes no sense.
Compiler in question is:
(void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
/* fix RT#19517 - special case 'undef' as string */
- if ( *s == 'u' && strEQ(s,"undef") ) {
+ if ( *s == 'u' && strEQ(s+1,"ndef") ) {
s += 5;
}
*/
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_CLASS_OBJ(ver,"version") ) /* can just copy directly */
+ if ( ISA_VERSION_OBJ(ver) ) /* can just copy directly */
{
SSize_t key;
AV * const av = newAV();
if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
(void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
-
- if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
{
- const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
- (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
+ SV ** svp = hv_fetchs(MUTABLE_HV(ver), "width", FALSE);
+ if(svp) {
+ const I32 width = SvIV(*svp);
+ (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
+ }
}
-
- if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
{
- SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
- (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
+ SV ** svp = hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
+ if(svp)
+ (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(*svp));
}
-
sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
/* This will get reblessed later if a derived class*/
for ( key = 0; key <= av_len(sav); key++ )
{
- const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
+ SV * const sv = *av_fetch(sav, key, FALSE);
+ const I32 rev = SvIV(sv);
av_push(av, newSViv(rev));
}
const MAGIC* const mg = SvVSTRING_mg(ver);
if ( mg ) { /* already a v-string */
const STRLEN len = mg->mg_len;
- char * const version = savepvn( (const char*)mg->mg_ptr, 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);
- Safefree(version);
}
else {
#endif
}
}
#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) && sv_len(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
- char *loc = NULL;
- if (! PL_numeric_standard) {
- loc = savepv(setlocale(LC_NUMERIC, NULL));
- setlocale(LC_NUMERIC, "C");
+ {
+ 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_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
- buf = SvPV(sv, len);
+ Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
+ len = SvCUR(sv);
+ buf = SvPVX(sv);
}
else {
len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
buf = tbuf;
}
-#ifdef USE_LOCALE_NUMERIC
- if (loc) {
- setlocale(LC_NUMERIC, loc);
- Safefree(loc);
- }
-#endif
+ 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);
+ SAVEFREEPV(version);
SvREFCNT_dec(sv);
}
#ifdef SvVOK
else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
+ SAVEFREEPV(version);
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);
- Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "Integer overflow in version %d",VERSION_MAX);
- }
- else if ( SvUOK(ver) || SvIOK(ver) ) {
- version = savesvpv(ver);
- }
- else /* 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));
+ SAVEFREEPV(version);
#ifndef SvVOK
# if PERL_VERSION > 5
/* This will only be executed for 5.6.0 - 5.8.0 inclusive */
int saw_decimal = 0;
sv_setpvf(nsv,"v%vd",ver);
pos = nver = savepv(SvPV_nolen(nsv));
+ SAVEFREEPV(pos);
/* scan the resulting formatted string */
pos++; /* skip the leading 'v' */
/* is definitely a v-string */
if ( saw_decimal >= 2 ) {
- Safefree(version);
version = nver;
}
break;
# 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_croak(aTHX_ "Invalid version format (non-numeric data)");
+ }
s = SCAN_VERSION(version, ver, qv);
if ( *s != '\0' )
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Version string '%s' contains invalid data; "
"ignoring: '%s'", version, s);
- Safefree(version);
+
+#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)
#endif
{
SV *sv;
+ SV **svp;
PERL_ARGS_ASSERT_VVERIFY;
/* see if the appropriate elements exist */
if ( SvTYPE(vs) == SVt_PVHV
- && hv_exists(MUTABLE_HV(vs), "version", 7)
- && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
+ && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
+ && (sv = SvRV(*svp))
&& SvTYPE(sv) == SVt_PVAV )
return vs;
else
*/
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;
- if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
- width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
- 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))) ) ) {
return newSVpvs("0");
}
- digit = SvIV(*av_fetch(av, 0, 0));
- sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
- for ( i = 1 ; i < len ; i++ )
{
- digit = SvIV(*av_fetch(av, i, 0));
- 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);
- }
+ SV * tsv = *av_fetch(av, 0, 0);
+ digit = SvIV(tsv);
}
-
- if ( len > 0 )
+ sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
+ for ( i = 1 ; i <= len ; i++ )
{
- digit = SvIV(*av_fetch(av, len, 0));
- if ( alpha && width == 3 ) /* alpha version */
- sv_catpvs(sv,"_");
- Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
+ SV * tsv = *av_fetch(av, i, 0);
+ digit = SvIV(tsv);
+ Perl_sv_catpvf(aTHX_ sv, "%03d", (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);
{
return newSVpvs("");
}
- digit = SvIV(*av_fetch(av, 0, 0));
+ {
+ SV * tsv = *av_fetch(av, 0, 0);
+ digit = SvIV(tsv);
+ }
sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
- for ( i = 1 ; i < len ; i++ ) {
- digit = SvIV(*av_fetch(av, i, 0));
+ 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 */
- digit = SvIV(*av_fetch(av, len, 0));
- 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)
#endif
{
+ SV ** svp;
PERL_ARGS_ASSERT_VSTRINGIFY;
/* extract the HV from the object */
if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
- if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
+ svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
+ if (svp) {
SV *pv;
- pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
- if ( SvPOK(pv) )
+ pv = *svp;
+ if ( SvPOK(pv)
+#if PERL_VERSION_LT(5,17,2)
+ || SvPOKp(pv)
+#endif
+ )
return newSVsv(pv);
else
return &PL_sv_undef;
*/
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 = 0;
while ( i <= m && retval == 0 )
{
- left = SvIV(*av_fetch(lav,i,0));
- right = SvIV(*av_fetch(rav,i,0));
+ SV * const lsv = *av_fetch(lav,i,0);
+ SV * rsv;
+ left = SvIV(lsv);
+ rsv = *av_fetch(rav,i,0);
+ right = SvIV(rsv);
if ( left < right )
retval = -1;
if ( left > right )
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 )
{
while ( i <= r && retval == 0 )
{
- if ( SvIV(*av_fetch(rav,i,0)) != 0 )
+ SV * const rsv = *av_fetch(rav,i,0);
+ if ( SvIV(rsv) != 0 )
retval = -1; /* not a match after all */
i++;
}
{
while ( i <= l && retval == 0 )
{
- if ( SvIV(*av_fetch(lav,i,0)) != 0 )
+ SV * const lsv = *av_fetch(lav,i,0);
+ if ( SvIV(lsv) != 0 )
retval = +1; /* not a match after all */
i++;
}
}
return retval;
}
+
+/* ex: set ro: */
https://perl5.git.perl.org / perl5.git / blobdiff