Version object combined patch

Message-ID: <3D9E593E.1060605@rowman.com>

p4raw-id: //depot/perl@17990

1 files changed, 164 insertions, 82 deletions

diff --git a/util.c b/util.c
index e7a6655313..80b17b7f3f 100644
--- a/util.c
+++ b/util.c
@@ -3967,7 +3967,6 @@ Perl_scan_vstring(pTHX_ char *s, SV *sv)
     return s;
 }
 
-
 /*
 =for apidoc scan_version
 
@@ -3989,38 +3988,82 @@ is a beta version).
 */
 
 char *
-Perl_scan_version(pTHX_ char *version, SV *rv)
+Perl_scan_version(pTHX_ char *s, SV *rv)
 {
-    char* d;
-    int beta = 0;
+    char *pos = s;
+    I32 saw_period = 0;
+    bool saw_under = 0;
     SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
-    d = version;
-    if (*d == 'v')
-	d++;
-    if (isDIGIT(*d)) {
-	while (isDIGIT(*d) || *d == '.' || *d == '\0')
-	    d++;
-	if (*d == '_') {
-	    *d = '.';
-	    if (*(d+1) == '0' && *(d+2) != '0') { /* perl-style version */
-		*(d+1) = *(d+2);
-		*(d+2) = '0';
-		if (ckWARN(WARN_PORTABLE))
-		    Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
-				"perl-style version not portable");
+    (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
+
+    /* pre-scan the imput string to check for decimals */
+    while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
+    {
+	if ( *pos == '.' )
+	{
+	    if ( saw_under )
+		croak(aTHX_ "Invalid version format (underscores before decimal)");
+	    saw_period++ ;
+	    }
+	else if ( *pos == '_' )
+	{
+	    if ( saw_under )
+		croak(aTHX_ "Invalid version format (multiple underscores)");
+	    saw_under = 1;
+	}
+	pos++;
+    }
+    pos = s;
+
+    if (*pos == 'v') pos++;  /* get past 'v' */
+    while (isDIGIT(*pos))
+    pos++;
+    if (!isALPHA(*pos)) {
+	I32 rev;
+
+	if (*s == 'v') s++;  /* get past 'v' */
+
+	for (;;) {
+	    rev = 0;
+	    {
+		/* this is atoi() that delimits on underscores */
+		char *end = pos;
+		I32 mult = 1;
+		if ( s < pos && *(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) )
+			croak(aTHX_ "Integer overflow in version");
+		}
 	    }
+
+	    /* Append revision */
+	    av_push((AV *)sv, newSViv(rev));
+	    if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
+		s = ++pos;
+	    else if ( isDIGIT(*pos) )
+		s = pos;
 	    else {
-		beta = -1;
+		s = pos;
+		break;
+	    }
+	    while ( isDIGIT(*pos) ) {
+		if ( saw_period == 1 && pos-s == 3 )
+		    break;
+		pos++;
 	    }
 	}
-	while (isDIGIT(*d) || *d == '.' || *d == '\0')
-	    d++;
-	if (*d == '_')
-	    Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
     }
-    version = scan_vstring(version, sv); /* store the v-string in the object */
-    SvIVX(sv) = beta;
-    return version;
+    return s;
 }
 
 /*
@@ -4040,15 +4083,14 @@ SV *
 Perl_new_version(pTHX_ SV *ver)
 {
     SV *rv = NEWSV(92,5);
-    char *version;
+    char *version = (char *)SvPV(ver,PL_na);
 
-    if ( SvMAGICAL(ver) ) { /* already a v-string */
+#ifdef SvVOK
+    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 );
     }
-    else {
-	version = (char *)SvPV_nolen(ver);
-    }
+#endif
     version = scan_version(version,rv);
     return rv;
 }
@@ -4066,93 +4108,133 @@ Returns a pointer to the upgraded SV.
 */
 
 SV *
-Perl_upg_version(pTHX_ SV *sv)
+Perl_upg_version(pTHX_ SV *ver)
 {
-    char *version = (char *)SvPV_nolen(sv_mortalcopy(sv));
-    bool utf8 = SvUTF8(sv);
-    if ( SvVOK(sv) ) { /* already a v-string */
-	SV * ver = newSVrv(sv, "version");
-	sv_setpv(ver,version);
-	if ( utf8 )
-	    SvUTF8_on(ver);
-    }
-    else {
-	version = scan_version(version,sv);
+    char *version = savepvn(SvPVX(ver),SvCUR(ver));
+#ifdef SvVOK
+    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 );
     }
-    return sv;
+#endif
+    version = scan_version(version,ver);
+    return ver;
 }
 
 
 /*
 =for apidoc vnumify
 
-Accepts a version (or vstring) object and returns the
-normalized floating point representation.  Call like:
+Accepts a version object and returns the normalized floating
+point representation.  Call like:
 
-    sv = vnumify(sv,SvRV(rv));
+    sv = vnumify(rv);
 
-NOTE: no checking is done to see if the object is of the
-correct type (for speed).
+NOTE: you can pass either the object directly or the SV
+contained within the RV.
 
 =cut
 */
 
 SV *
-Perl_vnumify(pTHX_ SV *sv, SV *vs)
+Perl_vnumify(pTHX_ SV *vs)
 {
-    U8* pv = (U8*)SvPVX(vs);
-    STRLEN len = SvCUR(vs);
-    STRLEN retlen;
-    UV digit = utf8_to_uvchr(pv,&retlen);
-    Perl_sv_setpvf(aTHX_ sv,"%"UVf".",digit);
-    for (pv += retlen, len -= retlen;
-	len > 0;
-	pv += retlen, len -= retlen)
+    I32 i, len, digit;
+    SV *sv = NEWSV(92,0);
+    if ( SvROK(vs) )
+	vs = SvRV(vs);
+    len = av_len((AV *)vs);
+    digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
+    Perl_sv_setpvf(aTHX_ sv,"%d.",abs(digit));
+    for ( i = 1 ; i <= len ; i++ )
     {
-	digit = utf8_to_uvchr(pv,&retlen);
-	Perl_sv_catpvf(aTHX_ sv,"%03"UVf,digit);
+	digit = SvIVX(*av_fetch((AV *)vs, i, 0));
+	Perl_sv_catpvf(aTHX_ sv,"%03d",abs(digit));
     }
+    if ( len == 0 )
+	 Perl_sv_catpv(aTHX_ sv,"000");
     return sv;
 }
 
 /*
 =for apidoc vstringify
 
-Accepts a version (or vstring) object and returns the
-normalized representation.  Call like:
+Accepts a version object and returns the normalized string
+representation.  Call like:
 
-    sv = vstringify(sv,SvRV(rv));
+    sv = vstringify(rv);
 
-NOTE: no checking is done to see if the object is of the
-correct type (for speed).
+NOTE: you can pass either the object directly or the SV
+contained within the RV.
 
 =cut
 */
 
 SV *
-Perl_vstringify(pTHX_ SV *sv, SV *vs)
+Perl_vstringify(pTHX_ SV *vs)
 {
-    U8* pv = (U8*)SvPVX(vs);
-    STRLEN len = SvCUR(vs);
-    STRLEN retlen;
-    UV digit = utf8_to_uvchr(pv,&retlen);
-    Perl_sv_setpvf(aTHX_ sv,"%"UVf,digit);
-    for (pv += retlen, len -= retlen;
-	len > 0;
-	pv += retlen, len -= retlen)
-    {
-	digit = utf8_to_uvchr(pv,&retlen);
-	Perl_sv_catpvf(aTHX_ sv,".%"UVf,digit);
-    }
-    if (SvIVX(vs) < 0) {
-	char* pv = SvPVX(sv); 
-	for (pv += SvCUR(sv); *pv != '.'; pv--)
-	    ;
-	*pv = '_';
+    I32 i, len, digit;
+    SV *sv = NEWSV(92,0);
+    if ( SvROK(vs) )
+	vs = SvRV(vs);
+    len = av_len((AV *)vs);
+    digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
+    Perl_sv_setpvf(aTHX_ sv,"%d",digit);
+    for ( i = 1 ; i <= len ; i++ )
+{
+	digit = SvIVX(*av_fetch((AV *)vs, i, 0));
+	if ( digit < 0 )
+	    Perl_sv_catpvf(aTHX_ sv,"_%d",-digit);
+	else
+	    Perl_sv_catpvf(aTHX_ sv,".%d",digit);
     }
+    if ( len == 0 )
+	 Perl_sv_catpv(aTHX_ sv,".0");
     return sv;
 }
 
+/*
+=for apidoc vcmp
+
+Version object aware cmp.  Both operands must already have been 
+converted into version objects.
+
+=cut
+*/
+
+int
+Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
+{
+    I32 i,l,m,r,retval;
+    if ( SvROK(lsv) )
+	lsv = SvRV(lsv);
+    if ( SvROK(rsv) )
+	rsv = SvRV(rsv);
+    l = av_len((AV *)lsv);
+    r = av_len((AV *)rsv);
+    m = l < r ? l : r;
+    retval = 0;
+    i = 0;
+    while ( i <= m && retval == 0 )
+    {
+	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  = abs(left);
+	right = abs(right);
+	if ( left < right || (left == right && lbeta && !rbeta) )
+	    retval = -1;
+	if ( left > right || (left == right && rbeta && !lbeta) )
+	    retval = +1;
+	i++;
+    }
+
+    if ( l != r && retval == 0 )
+	retval = l < r ? -1 : +1;
+    return retval;
+}
+
 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
 #   define EMULATE_SOCKETPAIR_UDP
 #endif