Final version object core patch?

Message-ID: <411048BD.3080700@rowman.com>

p4raw-id: //depot/perl@23190

7 files changed, 58 insertions, 97 deletions

diff --git a/gv.c b/gv.c
index 2c6641d6f6..d9d16ed0a4 100644
--- a/gv.c
+++ b/gv.c
@@ -1061,25 +1061,19 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     case ']':
 	if (len == 1) {
 	    SV *sv = GvSV(gv);
-	    (void)SvUPGRADE(sv, SVt_PVNV);
-	    Perl_sv_setpvf(aTHX_ sv,
-#if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
-			    "%8.6"
-#else
-			    "%5.3"
-#endif
-			    NVff,
-			    SvNVX(PL_patchlevel));
-	    SvNVX(sv) = SvNVX(PL_patchlevel);
-	    SvNOK_on(sv);
+	    if (!sv_derived_from(PL_patchlevel, "version"))
+		(void *)upg_version(PL_patchlevel);
+	    sv = vnumify(PL_patchlevel);
 	    SvREADONLY_on(sv);
+	    GvSV(gv) = sv;
 	}
 	break;
     case '\026':	/* $^V */
 	if (len == 1) {
 	    SV *sv = GvSV(gv);
-	    GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
-	    SvREFCNT_dec(sv);
+	    sv = new_version(PL_patchlevel);
+	    SvREADONLY_on(sv);
+	    GvSV(gv) = sv;
 	}
 	break;
     }
diff --git a/perl.c b/perl.c
index 4415d8d925..4af4e06e91 100644
--- a/perl.c
+++ b/perl.c
@@ -267,28 +267,6 @@ perl_construct(pTHXx)
     init_i18nl10n(1);
     SET_NUMERIC_STANDARD();
 
-    {
-	U8 *s;
-	PL_patchlevel = NEWSV(0,4);
-	(void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
-	if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
-	    SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
-	s = (U8*)SvPVX(PL_patchlevel);
-	/* Build version strings using "native" characters */
-	s = uvchr_to_utf8(s, (UV)PERL_REVISION);
-	s = uvchr_to_utf8(s, (UV)PERL_VERSION);
-	s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
-	*s = '\0';
-	SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
-	SvPOK_on(PL_patchlevel);
-	SvNVX(PL_patchlevel) = (NV)PERL_REVISION +
-			      ((NV)PERL_VERSION / (NV)1000) +
-			      ((NV)PERL_SUBVERSION / (NV)1000000);
-	SvNOK_on(PL_patchlevel);	/* dual valued */
-	SvUTF8_on(PL_patchlevel);
-	SvREADONLY_on(PL_patchlevel);
-    }
-
 #if defined(LOCAL_PATCH_COUNT)
     PL_localpatches = local_patches;	/* For possible -v */
 #endif
@@ -343,6 +321,13 @@ perl_construct(pTHXx)
 
     PL_stashcache = newHV();
 
+    PL_patchlevel = newSVpv(
+	    Perl_form(aTHX_ "%d.%d.%d",
+	    (int)PERL_REVISION,
+	    (int)PERL_VERSION,
+	    (int)PERL_SUBVERSION ), 0
+    );
+
     ENTER;
 }
 
@@ -2714,14 +2699,18 @@ Perl_moreswitches(pTHX_ char *s)
 	s++;
 	return s;
     case 'v':
+	if (!sv_derived_from(PL_patchlevel, "version"))
+		(void *)upg_version(PL_patchlevel);
 #if !defined(DGUX)
 	PerlIO_printf(PerlIO_stdout(),
-		      Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
-				PL_patchlevel, ARCHNAME));
+		Perl_form(aTHX_ "\nThis is perl, v%_ built for %s",
+		    vstringify(PL_patchlevel),
+		    ARCHNAME));
 #else /* DGUX */
 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
 	PerlIO_printf(PerlIO_stdout(),
-			Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
+		Perl_form(aTHX_ "\nThis is perl, v%_\n",
+		    vstringify(PL_patchlevel)));
 	PerlIO_printf(PerlIO_stdout(),
 			Perl_form(aTHX_ "        built under %s at %s %s\n",
 					OSNAME, __DATE__, __TIME__));
diff --git a/pp_ctl.c b/pp_ctl.c
index 7fd4c4ed2d..4ba11712f1 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3047,66 +3047,19 @@ PP(pp_require)
     OP *op;
 
     sv = POPs;
-    if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
-	if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {		/* require v5.6.1 */
-	    UV rev = 0, ver = 0, sver = 0;
-	    STRLEN len;
-	    U8 *s = (U8*)SvPVX(sv);
-	    U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
-	    if (s < end) {
-		rev = utf8n_to_uvchr(s, end - s, &len, 0);
-		s += len;
-		if (s < end) {
-		    ver = utf8n_to_uvchr(s, end - s, &len, 0);
-		    s += len;
-		    if (s < end)
-			sver = utf8n_to_uvchr(s, end - s, &len, 0);
-		}
-	    }
-	    if (PERL_REVISION < rev
-		|| (PERL_REVISION == rev
-		    && (PERL_VERSION < ver
-			|| (PERL_VERSION == ver
-			    && PERL_SUBVERSION < sver))))
-	    {
-		DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
-		    "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
-		    PERL_VERSION, PERL_SUBVERSION);
-	    }
-	    if (ckWARN(WARN_PORTABLE))
+    if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
+	if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )	/* require v5.6.1 */
 		Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
                         "v-string in use/require non-portable");
+
+	sv = new_version(sv);
+	if (!sv_derived_from(PL_patchlevel, "version"))
+	    (void *)upg_version(PL_patchlevel);
+	if ( vcmp(sv,PL_patchlevel) > 0 )
+	    DIE(aTHX_ "Perl v%_ required--this is only v%_, stopped",
+		vstringify(sv), vstringify(PL_patchlevel));
+
 	    RETPUSHYES;
-	}
-	else if (!SvPOKp(sv)) {			/* require 5.005_03 */
-	    if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
-		+ ((NV)PERL_SUBVERSION/(NV)1000000)
-		+ 0.00000099 < SvNV(sv))
-	    {
-		NV nrev = SvNV(sv);
-		UV rev = (UV)nrev;
-		NV nver = (nrev - rev) * 1000;
-		UV ver = (UV)(nver + 0.0009);
-		NV nsver = (nver - ver) * 1000;
-		UV sver = (UV)(nsver + 0.0009);
-
-		/* help out with the "use 5.6" confusion */
-		if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
-		    DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
-			" (did you mean v%"UVuf".%03"UVuf"?)--"
-			"this is only v%d.%d.%d, stopped",
-			rev, ver, sver, rev, ver/100,
-			PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
-		}
-		else {
-		    DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
-			"this is only v%d.%d.%d, stopped",
-			rev, ver, sver, PERL_REVISION, PERL_VERSION,
-			PERL_SUBVERSION);
-		}
-	    }
-	    RETPUSHYES;
-	}
     }
     name = SvPV(sv, len);
     if (!(name && len > 0 && *name))
diff --git a/sv.c b/sv.c
index 2cdebd66dc..e71c03c68b 100644
--- a/sv.c
+++ b/sv.c
@@ -9373,6 +9373,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		vecsv = svargs[efix ? efix-1 : svix++];
 		vecstr = (U8*)SvPVx(vecsv,veclen);
 		vec_utf8 = DO_UTF8(vecsv);
+		/* if this is a version object, we need to return the
+		 * stringified representation (which the SvPVX has
+		 * already done for us), but not vectorize the args
+		 */
+		if ( *q == 'd' && sv_derived_from(vecsv,"version") )
+		{
+			q++; /* skip past the rest of the %vd format */
+			eptr = vecstr;
+			elen = strlen(eptr);
+			vectorize=FALSE;
+			goto string;
+		}
 	    }
 	    else {
 		vecstr = (U8*)"";
diff --git a/t/comp/require.t b/t/comp/require.t
index 6931146ce8..29f5436df7 100755
--- a/t/comp/require.t
+++ b/t/comp/require.t
@@ -75,7 +75,7 @@ print "ok ",$i++,"\n";
 # check inaccurate fp
 $ver = 10.2;
 eval { require $ver; };
-print "# $@\nnot " unless $@ =~ /^Perl v10\.200\.0 required/;
+print "# $@\nnot " unless $@ =~ /^Perl v10\.200 required/;
 print "ok ",$i++,"\n";
 
 $ver = 10.000_02;
diff --git a/t/op/ver.t b/t/op/ver.t
index 79c36b6bc5..e030ec1000 100755
--- a/t/op/ver.t
+++ b/t/op/ver.t
@@ -222,7 +222,7 @@ ok( $v eq "$]", qq{\$^V eq "\$]"});
 
 $v = $revision + $version/1000 + $subversion/1000000;
 
-ok( $v == $], "\$^V == \$] (numeric)" );
+ok( abs($v - $]) < 10**-8 , "\$^V == \$] (numeric)" );
 
 SKIP: {
   skip("In EBCDIC the v-string components cannot exceed 2147483647", 6)
diff --git a/util.c b/util.c
index 02d65a683a..8d4c13e0a1 100644
--- a/util.c
+++ b/util.c
@@ -4004,6 +4004,19 @@ SV *
 Perl_new_version(pTHX_ SV *ver)
 {
     SV *rv = newSV(0);
+    if ( sv_derived_from(ver,"version") ) /* can just copy directly */
+    {
+	I32 key;
+	AV *av = (AV *)SvRV(ver);
+	SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+	(void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
+	for ( key = 0; key <= av_len(av); key++ )
+	{
+	    I32 rev = SvIV(*av_fetch(av, key, FALSE));
+	    av_push((AV *)sv, newSViv(rev));
+	}
+	return rv;
+    }
 #ifdef SvVOK
     if ( SvVOK(ver) ) { /* already a v-string */
 	char *version;