[Fwd: CPAN Upload: J/JP/JPEACOCK/version-0.47.tar.gz]

From: "John Peacock" <jpeacock@rowman.com>
Message-ID: <2444.85.65.24.143.1124818871.squirrel@webmail.rowman.com>

p4raw-id: //depot/perl@25325

1 files changed, 84 insertions, 25 deletions

diff --git a/util.c b/util.c
index 5824d873dd..f23e9cbb25 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));
+    sv_setpvf(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);
+	    sv_catpvf(sv, "%0*d_%d", width, term.quot, term.rem);
 	}
 	else {
-	    Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
+	    sv_catpvf(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);
+	sv_catpvf(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,36 +4279,40 @@ 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);
+    sv_setpvf(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);
+	sv_catpvf(sv, ".%"IVdf, (IV)digit);
     }
 
-    if ( len > 0 ) {
+    if ( len > 0 )
+    {
 	/* handle last digit specially */
 	digit = SvIV(*av_fetch(av, len, 0));
 	if ( alpha )
-	    Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
+	    sv_catpvf(sv, "_%"IVdf, (IV)digit);
 	else
-	    Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
+	    sv_catpvf(sv, ".%"IVdf, (IV)digit);
     }
 
     if ( len <= 2 ) { /* short version, must be at least three */
 	for ( len = 2 - len; len != 0; len-- )
 	    sv_catpvn(sv,".0",2);
     }
-
     return sv;
 }
 
@@ -4285,9 +4330,17 @@ 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) )
+	qv = 1;
+    
+    if ( qv )
 	return vnormal(vs);
     else
 	return vnumify(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 ) )