X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e2ca569edb67a22f6462e37bfcb6224f70b4416a..95b48ffed9f35642c9a79d792d8b8b7e363f9f4a:/vutil.c diff --git a/vutil.c b/vutil.c index 96aa6f6..4314fb9 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 @@ -28,7 +18,7 @@ some time when tokenizing. =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, @@ -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; @@ -259,7 +255,7 @@ it doesn't. */ 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) @@ -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 { @@ -453,13 +467,12 @@ want to upgrade the SV. */ 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 */ @@ -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_set(rv, SvCUR(rv) - 1); + *SvEND(rv) = '\0'; + } /* this is for consistency with the pure Perl class */ if ( isDIGIT(*version) ) sv_insert(rv, 0, 0, "v", 1); @@ -525,7 +547,8 @@ Perl_new_version(pTHX_ SV *ver) } } #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)); } /* @@ -542,21 +565,50 @@ to force this SV to be interpreted as an "extended" version. */ 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) #endif { + +#ifdef dVAR + dVAR; +#endif + const char *version, *s; #ifdef SvVOK 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; @@ -564,17 +616,128 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) char tbuf[64]; SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0; char *buf; - STORE_NUMERIC_LOCAL_SET_STANDARD(); + +#if PERL_VERSION_GE(5,19,0) + if (SvPOK(ver)) { + /* dualvar? */ + goto VER_PV; + } +#endif +#ifdef USE_LOCALE_NUMERIC + + { + /* This may or may not be called from code that has switched + * locales without letting perl know, therefore we have to find it + * from first principals. See [perl #121930]. */ + + /* In windows, or not threaded, or not thread-safe, if it isn't C, + * set it to C. */ + +# ifndef USE_POSIX_2008_LOCALE + + const char * locale_name_on_entry; + + LC_NUMERIC_LOCK(0); /* Start critical section */ + + locale_name_on_entry = setlocale(LC_NUMERIC, NULL); + if ( strNE(locale_name_on_entry, "C") + && strNE(locale_name_on_entry, "POSIX")) + { + setlocale(LC_NUMERIC, "C"); + } + else { /* This value indicates to the restore code that we didn't + change the locale */ + locale_name_on_entry = NULL; + } + +# else + + const locale_t locale_obj_on_entry = uselocale((locale_t) 0); + const char * locale_name_on_entry = NULL; + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + + if (locale_obj_on_entry == LC_GLOBAL_LOCALE) { + + /* in the global locale, we can call system setlocale and if it + * isn't C, set it to C. */ + LC_NUMERIC_LOCK(0); + + locale_name_on_entry = setlocale(LC_NUMERIC, NULL); + if ( strNE(locale_name_on_entry, "C") + && strNE(locale_name_on_entry, "POSIX")) + { + setlocale(LC_NUMERIC, "C"); + } + else { /* This value indicates to the restore code that we + didn't change the locale */ + locale_name_on_entry = NULL; + } + } + else if (locale_obj_on_entry == PL_underlying_numeric_obj) { + /* Here, the locale appears to have been changed to use the + * program's underlying locale. Just use our mechanisms to + * switch back to C. It might be possible for this pointer to + * actually refer to something else if it got released and + * reused somehow. But it doesn't matter, our mechanisms will + * work even so */ + STORE_LC_NUMERIC_SET_STANDARD(); + } + else if (locale_obj_on_entry != PL_C_locale_obj) { + /* The C object should be unchanged during a program's + * execution, so it should be safe to assume it means what it + * says, so if we are in it, no locale change is required. + * Otherwise, simply use the thread-safe operation. */ + uselocale(PL_C_locale_obj); + } + +# endif + + /* Prevent recursed calls from trying to change back */ + LOCK_LC_NUMERIC_STANDARD(); + +#endif + if (sv) { - Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver)); + 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)); + len = my_snprintf(tbuf, sizeof(tbuf), "%.9" NVff, SvNVX(ver)); buf = tbuf; } - RESTORE_NUMERIC_LOCAL(); + +#ifdef USE_LOCALE_NUMERIC + + UNLOCK_LC_NUMERIC_STANDARD(); + +# ifndef USE_POSIX_2008_LOCALE + + if (locale_name_on_entry) { + setlocale(LC_NUMERIC, locale_name_on_entry); + } + + LC_NUMERIC_UNLOCK; /* End critical section */ + +# else + + if (locale_name_on_entry) { + setlocale(LC_NUMERIC, locale_name_on_entry); + LC_NUMERIC_UNLOCK; + } + else if (locale_obj_on_entry == PL_underlying_numeric_obj) { + RESTORE_LC_NUMERIC(); + } + else if (locale_obj_on_entry != PL_C_locale_obj) { + uselocale(locale_obj_on_entry); + } + +# endif + + } + +#endif /* USE_LOCALE_NUMERIC */ + while (buf[len-1] == '0' && len > 0) len--; if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */ version = savepvn(buf, len); @@ -588,22 +751,8 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) 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)); @@ -645,6 +794,17 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) # 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 */ @@ -656,7 +816,11 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) 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; } @@ -687,7 +851,7 @@ confused by derived classes which may contain additional hash entries): */ SV * -#if VUTIL_REPLACE_CORE +#ifdef VUTIL_REPLACE_CORE Perl_vverify2(pTHX_ SV *vs) #else Perl_vverify(pTHX_ SV *vs) @@ -728,7 +892,7 @@ The SV returned has a refcount of 1. */ SV * -#if VUTIL_REPLACE_CORE +#ifdef VUTIL_REPLACE_CORE Perl_vnumify2(pTHX_ SV *vs) #else Perl_vnumify(pTHX_ SV *vs) @@ -736,7 +900,6 @@ Perl_vnumify(pTHX_ SV *vs) { SSize_t i, len; I32 digit; - int width; bool alpha = FALSE; SV *sv; AV *av; @@ -751,14 +914,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))) ) ) { @@ -776,30 +936,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; @@ -822,14 +966,13 @@ The SV returned has a refcount of 1. */ 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; @@ -840,8 +983,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); @@ -853,22 +994,11 @@ Perl_vnormal(pTHX_ SV *vs) SV * tsv = *av_fetch(av, 0, 0); digit = SvIV(tsv); } - sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit); - for ( i = 1 ; i < len ; i++ ) { + sv = Perl_newSVpvf(aTHX_ "v%" IVdf, (IV)digit); + 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); + Perl_sv_catpvf(aTHX_ sv, ".%" IVdf, (IV)digit); } if ( len <= 2 ) { /* short version, must be at least three */ @@ -892,7 +1022,7 @@ The SV returned has a refcount of 1. */ SV * -#if VUTIL_REPLACE_CORE +#ifdef VUTIL_REPLACE_CORE Perl_vstringify2(pTHX_ SV *vs) #else Perl_vstringify(pTHX_ SV *vs) @@ -910,7 +1040,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; @@ -933,7 +1067,7 @@ converted into version objects. */ int -#if VUTIL_REPLACE_CORE +#ifdef VUTIL_REPLACE_CORE Perl_vcmp2(pTHX_ SV *lhv, SV *rhv) #else Perl_vcmp(pTHX_ SV *lhv, SV *rhv) @@ -941,8 +1075,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; @@ -957,13 +1089,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); @@ -984,19 +1112,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 ) @@ -1022,3 +1137,5 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) } return retval; } + +/* ex: set ro: */