/* 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
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;
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 {
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);
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) {
}
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);
}
#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));
{
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;
#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");
if (svp) {
SV *pv;
pv = *svp;
- if ( SvPOK(pv) )
+ if ( SvPOK(pv)
+#if PERL_VERSION_LT(5,17,2)
+ || SvPOKp(pv)
+#endif
+ )
return newSVsv(pv);
else
return &PL_sv_undef;
{
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: */
https://perl5.git.perl.org / perl5.git / blobdiff