Final version object core patch?

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

p4raw-id: //depot/perl@23190

diff --git a/gv.c b/gv.c
index 2c6641d..d9d16ed 100644 (file)
--- 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 4415d8d..4af4e06 100644 (file)
--- 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 7fd4c4e..4ba1171 100644 (file)
--- 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 2cdebd6..e71c03c 100644 (file)
--- 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 6931146..29f5436 100755 (executable)
--- 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 79c36b6..e030ec1 100755 (executable)
--- 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 02d65a6..8d4c13e 100644 (file)
--- 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;