From: John Peacock Date: Tue, 3 Aug 2004 22:23:57 +0000 (-0400) Subject: Final version object core patch? X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d7aa53827cc12fdf8a697328df844e16aaa58287;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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;