X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7738054cc936a59cb4b0e0da328f287c9ec8a98a..37537123896a527fb35f766e0ddaaacb49c38dc1:/vutil.c diff --git a/vutil.c b/vutil.c index 6f92d33..34c0b55 100644 --- a/vutil.c +++ b/vutil.c @@ -1,19 +1,9 @@ /* 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 @@ -42,6 +32,7 @@ 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; @@ -224,6 +215,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; @@ -310,7 +306,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; @@ -330,6 +326,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; @@ -348,17 +346,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; } } } @@ -369,8 +377,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]) ) @@ -382,7 +396,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) break; } if ( qv ) { - while ( isDIGIT(*pos) ) + while ( isDIGIT(*pos) || *pos == '_') pos++; } else { @@ -459,7 +473,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 */ @@ -513,7 +526,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); @@ -589,6 +611,47 @@ 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); + } + } +#endif + { /* Braces needed because macro just below declares a variable */ STORE_NUMERIC_LOCAL_SET_STANDARD(); LOCK_NUMERIC_STANDARD(); if (sv) { @@ -602,6 +665,7 @@ VER_NV: } 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); @@ -616,9 +680,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)); @@ -766,7 +828,6 @@ Perl_vnumify(pTHX_ SV *vs) { SSize_t i, len; I32 digit; - int width; bool alpha = FALSE; SV *sv; AV *av; @@ -781,14 +842,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))) ) ) { @@ -806,30 +864,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; @@ -859,7 +901,6 @@ Perl_vnormal(pTHX_ SV *vs) #endif { I32 i, len, digit; - bool alpha = FALSE; SV *sv; AV *av; @@ -870,8 +911,6 @@ Perl_vnormal(pTHX_ SV *vs) 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); @@ -884,23 +923,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"); @@ -940,7 +968,11 @@ Perl_vstringify(pTHX_ SV *vs) 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; @@ -971,8 +1003,6 @@ 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; @@ -987,13 +1017,9 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) /* 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); @@ -1014,19 +1040,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 ) @@ -1052,3 +1065,5 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) } return retval; } + +/* ex: set ro: */