X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4141ef59170e80715499432a2f4b9bfca704247d..a9b1083885574fdefca2a659d936647c5ca05870:/vutil.c diff --git a/vutil.c b/vutil.c index 303e76c..c033820 100644 --- a/vutil.c +++ b/vutil.c @@ -1,18 +1,9 @@ /* 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 @@ -27,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, @@ -41,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; @@ -223,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; @@ -258,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) @@ -283,8 +280,7 @@ 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); } } @@ -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 { @@ -396,7 +410,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) } } 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: @@ -432,7 +446,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) (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; } @@ -453,16 +467,15 @@ 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_CLASS_OBJ(ver,"version") ) /* can just copy directly */ + if ( ISA_VERSION_OBJ(ver) ) /* can just copy directly */ { SSize_t key; AV * const av = newAV(); @@ -478,29 +491,29 @@ Perl_new_version(pTHX_ SV *ver) ver = SvRV(ver); /* Begin copying all of the elements */ - if ( hv_exists(MUTABLE_HV(ver), "qv", 2) ) + if ( hv_existss(MUTABLE_HV(ver), "qv") ) (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1)); - if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) ) + if ( hv_existss(MUTABLE_HV(ver), "alpha") ) (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)); } @@ -512,21 +525,30 @@ Perl_new_version(pTHX_ SV *ver) 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 - sv_setsv(rv,ver); /* make a duplicate */ + SvSetSV_nosteal(rv, ver); /* make a duplicate */ #ifdef SvVOK } } #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)); } /* @@ -543,7 +565,7 @@ 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) @@ -554,9 +576,34 @@ 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; @@ -564,51 +611,80 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) 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) ) { - 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 /* 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 */ @@ -625,6 +701,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) 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' */ @@ -636,7 +713,6 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) /* is definitely a v-string */ if ( saw_decimal >= 2 ) { - Safefree(version); version = nver; } break; @@ -646,13 +722,33 @@ 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 */ + 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; } @@ -683,13 +779,14 @@ 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) #endif { SV *sv; + SV **svp; PERL_ARGS_ASSERT_VVERIFY; @@ -698,8 +795,8 @@ Perl_vverify(pTHX_ SV *vs) /* 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 @@ -723,7 +820,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) @@ -731,7 +828,6 @@ Perl_vnumify(pTHX_ SV *vs) { SSize_t i, len; I32 digit; - int width; bool alpha = FALSE; SV *sv; AV *av; @@ -744,13 +840,13 @@ Perl_vnumify(pTHX_ SV *vs) Perl_croak(aTHX_ "Invalid version object"); /* see if various flags exist */ - if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) + if ( hv_existss(MUTABLE_HV(vs), "alpha") ) 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))) ) ) { @@ -763,30 +859,19 @@ Perl_vnumify(pTHX_ SV *vs) 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; @@ -809,14 +894,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; @@ -827,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); @@ -836,23 +918,17 @@ Perl_vnormal(pTHX_ SV *vs) { 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"); @@ -874,12 +950,13 @@ 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) #endif { + SV ** svp; PERL_ARGS_ASSERT_VSTRINGIFY; /* extract the HV from the object */ @@ -887,16 +964,21 @@ Perl_vstringify(pTHX_ SV *vs) 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; } else { - if ( hv_exists(MUTABLE_HV(vs), "qv", 2) ) + if ( hv_existss(MUTABLE_HV(vs), "qv") ) return VNORMAL(vs); else return VNUMIFY(vs); @@ -913,7 +995,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) @@ -921,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; @@ -937,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); @@ -952,8 +1028,11 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) 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 ) @@ -961,26 +1040,14 @@ 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 ) { 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++; } @@ -989,7 +1056,8 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) { 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++; } @@ -997,3 +1065,5 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) } return retval; } + +/* ex: set ro: */