From: John Peacock <jpeacock@rowman.com>
Date: Wed, 28 Aug 2002 22:13:48 +0000 (-0400)
Subject: Tweaks to Bleadperl Version Object Support
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=be2ebcad4cb2c045db0ae053b6c5441f145b68c6;p=p5sagit%2Fp5-mst-13.2.git

Tweaks to Bleadperl Version Object Support
Message-ID: <3D6D835C.50809@rowman.com>

p4raw-id: //depot/perl@17819
---

diff --git a/universal.c b/universal.c
index 4a879e9..7e80da2 100644
--- a/universal.c
+++ b/universal.c
@@ -192,6 +192,7 @@ Perl_boot_core_UNIVERSAL(pTHX)
 	sv_inc(sv);
 	SvSETMAGIC(sv);
 	/* Make it findable via fetchmethod */
+	newXS("version::()", XS_version_noop, file);
 	newXS("version::new", XS_version_new, file);
 	newXS("version::(\"\"", XS_version_stringify, file);
 	newXS("version::stringify", XS_version_stringify, file);
diff --git a/util.c b/util.c
index 35fb8a8..cf793bd 100644
--- a/util.c
+++ b/util.c
@@ -4155,27 +4155,34 @@ is a beta version).
 char *
 Perl_scan_version(pTHX_ char *version, SV *rv)
 {
-    char *d;
+    char* d;
     int beta = 0;
-    SV * sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+    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 == '.')
+	while (isDIGIT(*d) || *d == '.' || *d == '\0')
 	    d++;
-	if ( *d == '_' ) {
+	if (*d == '_') {
 	    *d = '.';
-	    if ( *(d+1) == '0' && *(d+2) != '0' ) { /* perl-style version */
+	    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");
 	    }
 	    else {
 		beta = -1;
 	    }
 	}
+	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 */
+    version = scan_vstring(version, sv); /* store the v-string in the object */
     SvIVX(sv) = beta;
     return version;
 }
@@ -4299,10 +4306,14 @@ Perl_vstringify(pTHX_ SV *sv, SV *vs)
 	pv += retlen, len -= retlen)
     {
 	digit = utf8_to_uvchr(pv,&retlen);
-	Perl_sv_catpvf(aTHX_ sv,".%03"UVf,digit);
+	Perl_sv_catpvf(aTHX_ sv,".%"UVf,digit);
+    }
+    if (SvIVX(vs) < 0) {
+	char* pv = SvPVX(sv); 
+	for (pv += SvCUR(sv); *pv != '.'; pv--)
+	    ;
+	*pv = '_';
     }
-    if ( SvIVX(vs) < 0 )
-	sv_catpv(sv,"beta");
     return sv;
 }