X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=8dd0784922927a148eb312ef10bb0cfedc53dd82;hb=261fcdab08d4144aee77d6e62cd6bdfc3c1a418e;hp=5824d873ddd48d0f4f5a552cd4585ba199cd0b2c;hpb=3dd43144814f745bf49c14c0667bcc87206dc13f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 5824d87..8dd0784 100644 --- a/util.c +++ b/util.c @@ -3878,7 +3878,7 @@ it doesn't. const char * Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) { - const char *start = s; + const char *start; const char *pos; const char *last; int saw_period = 0; @@ -3891,12 +3891,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) HvSHAREKEYS_on(hv); /* key-sharing on by default */ #endif + while (isSPACE(*s)) /* leading whitespace is OK */ + s++; + if (*s == 'v') { s++; /* get past 'v' */ qv = 1; /* force quoted version processing */ } - last = pos = s; + start = last = pos = s; /* pre-scan the input string to check for decimals/underbars */ while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) @@ -3918,17 +3921,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) pos++; } - if ( saw_period > 1 ) { + if ( saw_period > 1 ) qv = 1; /* force quoted version processing */ - } pos = s; if ( qv ) hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0); - if ( saw_under ) { + if ( saw_under ) hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); - } if ( !qv && width < 3 ) hv_store((HV *)hv, "width", 5, newSViv(width), 0); @@ -3949,7 +3950,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) * point of a version originally created with a bare * floating point number, i.e. not quoted in any way */ - if ( !qv && s > start+1 && saw_period == 1 ) { + if ( !qv && s > start && saw_period == 1 ) { mult *= 100; while ( s < end ) { orev = rev; @@ -4044,7 +4045,7 @@ Perl_new_version(pTHX_ SV *ver) AV * const av = newAV(); AV *sav; /* This will get reblessed later if a derived class*/ - SV* const hv = newSVrv(rv, "version"); + SV * const hv = newSVrv(rv, "version"); (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ #ifndef NODEFAULT_SHAREKEYS HvSHAREKEYS_on(hv); /* key-sharing on by default */ @@ -4079,7 +4080,7 @@ Perl_new_version(pTHX_ SV *ver) } #ifdef SvVOK if ( SvVOK(ver) ) { /* already a v-string */ - MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); + const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring); const STRLEN len = mg->mg_len; char * const version = savepvn( (const char*)mg->mg_ptr, len); sv_setpvn(rv,version,len); @@ -4135,6 +4136,45 @@ Perl_upg_version(pTHX_ SV *ver) return ver; } +/* +=for apidoc vverify + +Validates that the SV contains a valid version object. + + bool vverify(SV *vobj); + +Note that it only confirms the bare minimum structure (so as not to get +confused by derived classes which may contain additional hash entries): + +=over 4 + +=item * The SV contains a hash (or a reference to one) + +=item * The hash contains a "version" key + +=item * The "version" key has an AV as its value + +=back + +=cut +*/ + +bool +Perl_vverify(pTHX_ SV *vs) +{ + SV *sv; + if ( SvROK(vs) ) + vs = SvRV(vs); + + /* see if the appropriate elements exist */ + if ( SvTYPE(vs) == SVt_PVHV + && hv_exists((HV*)vs, "version", 7) + && (sv = *hv_fetch((HV*)vs, "version", 7, FALSE)) + && SvTYPE(sv) == SVt_PVAV ) + return TRUE; + else + return FALSE; +} /* =for apidoc vnumify @@ -4161,6 +4201,9 @@ Perl_vnumify(pTHX_ SV *vs) if ( SvROK(vs) ) vs = SvRV(vs); + if ( !vverify(vs) ) + Perl_croak(aTHX_ "Invalid version object"); + /* see if various flags exist */ if ( hv_exists((HV*)vs, "alpha", 5 ) ) alpha = TRUE; @@ -4184,17 +4227,17 @@ Perl_vnumify(pTHX_ SV *vs) } digit = SvIV(*av_fetch(av, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit)); + Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit)); for ( i = 1 ; i < len ; i++ ) { digit = SvIV(*av_fetch(av, i, 0)); if ( width < 3 ) { const int denom = (int)pow(10,(3-width)); const div_t term = div((int)PERL_ABS(digit),denom); - Perl_sv_catpvf(aTHX_ sv,"%0*d_%d", width, term.quot, term.rem); + 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, "%0*d", width, (int)digit); } } @@ -4202,14 +4245,12 @@ Perl_vnumify(pTHX_ SV *vs) { digit = SvIV(*av_fetch(av, len, 0)); if ( alpha && width == 3 ) /* alpha version */ - Perl_sv_catpv(aTHX_ sv,"_"); - /* Don't display additional trailing zeros */ - if ( digit > 0 ) - Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit); + sv_catpvn(sv,"_",1); + Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); } - else /* len == 1 */ + else /* len == 0 */ { - sv_catpvn(sv,"000",3); + sv_catpvn(sv,"000",3); } return sv; } @@ -4238,23 +4279,28 @@ Perl_vnormal(pTHX_ SV *vs) if ( SvROK(vs) ) vs = SvRV(vs); + if ( !vverify(vs) ) + Perl_croak(aTHX_ "Invalid version object"); + if ( hv_exists((HV*)vs, "alpha", 5 ) ) alpha = TRUE; av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE); len = av_len(av); - if ( len == -1 ) { + if ( len == -1 ) + { sv_catpvn(sv,"",0); return sv; } digit = SvIV(*av_fetch(av, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"v%"IVdf,(IV)digit); + Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit); for ( i = 1 ; i <= len-1 ; i++ ) { digit = SvIV(*av_fetch(av, i, 0)); Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); } - if ( len > 0 ) { + if ( len > 0 ) + { /* handle last digit specially */ digit = SvIV(*av_fetch(av, len, 0)); if ( alpha ) @@ -4267,7 +4313,6 @@ Perl_vnormal(pTHX_ SV *vs) for ( len = 2 - len; len != 0; len-- ) sv_catpvn(sv,".0",2); } - return sv; } @@ -4285,12 +4330,20 @@ the original version contained 1 or more dots, respectively SV * Perl_vstringify(pTHX_ SV *vs) { + I32 qv = 0; if ( SvROK(vs) ) vs = SvRV(vs); + + if ( !vverify(vs) ) + Perl_croak(aTHX_ "Invalid version object"); + if ( hv_exists((HV *)vs, "qv", 2) ) - return vnormal(vs); + qv = 1; + + if ( qv ) + return Perl_vnormal(aTHX_ vs); else - return vnumify(vs); + return Perl_vnumify(aTHX_ vs); } /* @@ -4316,6 +4369,12 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) if ( SvROK(rhv) ) rhv = SvRV(rhv); + if ( !vverify(lhv) ) + Perl_croak(aTHX_ "Invalid version object"); + + if ( !vverify(rhv) ) + Perl_croak(aTHX_ "Invalid version object"); + /* get the left hand term */ lav = (AV *)*hv_fetch((HV*)lhv, "version", 7, FALSE); if ( hv_exists((HV*)lhv, "alpha", 5 ) )