version objects final(?) patch

Message-ID: <3E18E9D9.2040908@rowman.com>

p4raw-id: //depot/perl@18682

1 files changed, 46 insertions, 25 deletions

diff --git a/util.c b/util.c
index 7f32acbc3e..7664f60334 100644
--- a/util.c
+++ b/util.c
@@ -3763,26 +3763,40 @@ Perl_scan_version(pTHX_ char *s, SV *rv)
 	for (;;) {
 	    rev = 0;
 	    {
-		/* this is atoi() that delimits on underscores */
-		char *end = pos;
-		I32 mult = 1;
-		if ( s < pos && s > start && *(s-1) == '_' ) {
-		    if ( *s == '0' && *(s+1) != '0')
-			mult = 10;	/* perl-style */
-		    else
-			mult = -1;	/* beta version */
-		}
-		while (--end >= s) {
-		    I32 orev;
-		    orev = rev;
-		    rev += (*end - '0') * mult;
-		    mult *= 10;
-		    if ( abs(orev) > abs(rev) )
-			Perl_croak(aTHX_ "Integer overflow in version");
-		}
-	    }
-
-	    /* Append revision */
+  		/* this is atoi() that delimits on underscores */
+  		char *end = pos;
+  		I32 mult = 1;
+ 		I32 orev;
+  		if ( s < pos && s > start && *(s-1) == '_' ) {
+ 			mult *= -1;	/* beta version */
+  		}
+		/* the following if() will only be true after the decimal
+		 * point of a version originally created with a bare
+		 * floating point number, i.e. not quoted in any way
+		 */
+ 		if ( s > start+1 && saw_period == 1 && !saw_under ) {
+ 		    mult = 100;
+ 		    while ( s < end ) {
+ 			orev = rev;
+ 			rev += (*s - '0') * mult;
+ 			mult /= 10;
+ 			if ( abs(orev) > abs(rev) )
+ 			    Perl_croak(aTHX_ "Integer overflow in version");
+ 			s++;
+ 		    }
+  		}
+ 		else {
+ 		    while (--end >= s) {
+ 			orev = rev;
+ 			rev += (*end - '0') * mult;
+ 			mult *= 10;
+ 			if ( abs(orev) > abs(rev) )
+ 			    Perl_croak(aTHX_ "Integer overflow in version");
+ 		    }
+ 		} 
+  	    }
+  
+  	    /* Append revision */
 	    av_push((AV *)sv, newSViv(rev));
 	    if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
 		s = ++pos;
@@ -3818,7 +3832,7 @@ want to upgrade the SV.
 SV *
 Perl_new_version(pTHX_ SV *ver)
 {
-    SV *rv = NEWSV(92,5);
+    SV *rv = newSV(0);
     char *version;
     if ( SvNOK(ver) ) /* may get too much accuracy */ 
     {
@@ -3832,7 +3846,7 @@ Perl_new_version(pTHX_ SV *ver)
 	version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
     }
 #endif
-    else
+    else /* must be a string or something like a string */
     {
 	version = (char *)SvPV(ver,PL_na);
     }
@@ -3903,6 +3917,7 @@ Perl_vnumify(pTHX_ SV *vs)
     }
     if ( len == 0 )
 	 Perl_sv_catpv(aTHX_ sv,"000");
+    sv_setnv(sv, SvNV(sv));
     return sv;
 }
 
@@ -3946,7 +3961,7 @@ Perl_vstringify(pTHX_ SV *vs)
     if ( len == 0 )
 	 Perl_sv_catpv(aTHX_ sv,".0");
     return sv;
-}
+} 
 
 /*
 =for apidoc vcmp
@@ -3985,8 +4000,14 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
 	i++;
     }
 
-    if ( l != r && retval == 0 )
-	retval = l < r ? -1 : +1;
+    if ( l != r && retval == 0 ) /* possible match except for trailing 0 */
+    {
+	if ( !( l < r && r-l == 1 && SvIV(*av_fetch((AV *)rsv,r,0)) == 0 ) &&
+	     !( l-r == 1 && SvIV(*av_fetch((AV *)lsv,l,0)) == 0 ) )
+	{
+	    retval = l < r ? -1 : +1; /* not a match after all */
+	}
+    }
     return retval;
 }