was Re: [Fwd: CPAN Upload: J/JP/JPEACOCK/version-0.36.tar.gz]

Message-ID: <401DB17F.5060808@rowman.com>

p4raw-id: //depot/perl@22264

1 files changed, 70 insertions, 36 deletions

diff --git a/util.c b/util.c
index b20cd8c953..0927477432 100644
--- a/util.c
+++ b/util.c
@@ -3663,19 +3663,21 @@ an RV.
 
 Function must be called with an already existing SV like
 
-    sv = NEWSV(92,0);
-    s = scan_version(s,sv);
+    sv = newSV(0);
+    s = scan_version(s,SV *sv, bool qv);
 
 Performs some preprocessing to the string to ensure that
 it has the correct characteristics of a version.  Flags the
 object if it contains an underscore (which denotes this
-is a beta version).
+is a alpha version).  The boolean qv denotes that the version
+should be interpreted as if it had multiple decimals, even if
+it doesn't.
 
 =cut
 */
 
 char *
-Perl_scan_version(pTHX_ char *s, SV *rv)
+Perl_scan_version(pTHX_ char *s, SV *rv, bool qv)
 {
     const char *start = s;
     char *pos = s;
@@ -3703,7 +3705,10 @@ Perl_scan_version(pTHX_ char *s, SV *rv)
     }
     pos = s;
 
-    if (*pos == 'v') pos++;  /* get past 'v' */
+    if (*pos == 'v') {
+	pos++;  /* get past 'v' */
+	qv = 1; /* force quoted version processing */
+    }
     while (isDIGIT(*pos))
 	pos++;
     if (!isALPHA(*pos)) {
@@ -3719,13 +3724,13 @@ Perl_scan_version(pTHX_ char *s, SV *rv)
   		I32 mult = 1;
  		I32 orev;
   		if ( s < pos && s > start && *(s-1) == '_' ) {
- 			mult *= -1;	/* beta version */
+ 			mult *= -1;	/* alpha 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 ) {
+ 		if ( !qv && s > start+1 && saw_period == 1 && !saw_under ) {
  		    mult = 100;
  		    while ( s < end ) {
  			orev = rev;
@@ -3784,24 +3789,21 @@ SV *
 Perl_new_version(pTHX_ SV *ver)
 {
     SV *rv = newSV(0);
-    char *version;
-    if ( SvNOK(ver) ) /* may get too much accuracy */ 
-    {
-	char tbuf[64];
-	sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
-	version = savepv(tbuf);
-    }
 #ifdef SvVOK
-    else if ( SvVOK(ver) ) { /* already a v-string */
+    if ( SvVOK(ver) ) { /* already a v-string */
+	char *version;
 	MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
 	version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
+	sv_setpv(rv,version);
+	Safefree(version);
     }
+    else {
 #endif
-    else /* must be a string or something like a string */
-    {
-	version = (char *)SvPV(ver,PL_na);
+    sv_setsv(rv,ver); /* make a duplicate */
+#ifdef SvVOK
     }
-    version = scan_version(version,rv);
+#endif
+    upg_version(rv);
     return rv;
 }
 
@@ -3820,14 +3822,29 @@ Returns a pointer to the upgraded SV.
 SV *
 Perl_upg_version(pTHX_ SV *ver)
 {
-    char *version = savepvn(SvPVX(ver),SvCUR(ver));
+    char *version;
+    bool qv = 0;
+
+    if ( SvNOK(ver) ) /* may get too much accuracy */ 
+    {
+	char tbuf[64];
+	sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
+	version = savepv(tbuf);
+    }
 #ifdef SvVOK
-    if ( SvVOK(ver) ) { /* already a v-string */
+    else if ( SvVOK(ver) ) { /* already a v-string */
 	MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
 	version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
+	qv = 1;
     }
 #endif
-    version = scan_version(version,ver);
+    else /* must be a string or something like a string */
+    {
+	STRLEN n_a;
+	version = savepv(SvPV(ver,n_a));
+    }
+    (void)scan_version(version, ver, qv);
+    Safefree(version);
     return ver;
 }
 
@@ -3850,7 +3867,7 @@ SV *
 Perl_vnumify(pTHX_ SV *vs)
 {
     I32 i, len, digit;
-    SV *sv = NEWSV(92,0);
+    SV *sv = newSV(0);
     if ( SvROK(vs) )
 	vs = SvRV(vs);
     len = av_len((AV *)vs);
@@ -3890,7 +3907,7 @@ SV *
 Perl_vstringify(pTHX_ SV *vs)
 {
     I32 i, len, digit;
-    SV *sv = NEWSV(92,0);
+    SV *sv = newSV(0);
     if ( SvROK(vs) )
 	vs = SvRV(vs);
     len = av_len((AV *)vs);
@@ -3909,8 +3926,12 @@ Perl_vstringify(pTHX_ SV *vs)
 	else
 	    Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
     }
-    if ( len == 0 )
-	 Perl_sv_catpv(aTHX_ sv,".0");
+    
+    if ( len <= 2 ) { /* short version, must be at least three */
+	for ( len = 2 - len; len != 0; len-- )
+	    Perl_sv_catpv(aTHX_ sv,".0");
+    }
+
     return sv;
 } 
 
@@ -3940,23 +3961,36 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
     {
 	I32 left  = SvIV(*av_fetch((AV *)lsv,i,0));
 	I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
-	bool lbeta = left  < 0 ? 1 : 0;
-	bool rbeta = right < 0 ? 1 : 0;
-	left  = PERL_ABS(left);
-	right = PERL_ABS(right);
-	if ( left < right || (left == right && lbeta && !rbeta) )
+	bool lalpha = left  < 0 ? 1 : 0;
+	bool ralpha = right < 0 ? 1 : 0;
+	left  = abs(left);
+	right = abs(right);
+	if ( left < right || (left == right && lalpha && !ralpha) )
 	    retval = -1;
-	if ( left > right || (left == right && rbeta && !lbeta) )
+	if ( left > right || (left == right && ralpha && !lalpha) )
 	    retval = +1;
 	i++;
     }
 
-    if ( l != r && retval == 0 ) /* possible match except for trailing 0 */
+    if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
     {
-	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 ) )
+	if ( l < r )
 	{
-	    retval = l < r ? -1 : +1; /* not a match after all */
+	    while ( i <= r && retval == 0 )
+	    {
+		if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
+		    retval = -1; /* not a match after all */
+		i++;
+	    }
+	}
+	else
+	{
+	    while ( i <= l && retval == 0 )
+	    {
+		if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
+		    retval = +1; /* not a match after all */
+		i++;
+	    }
 	}
     }
     return retval;