Upgrade to version.pm 0.71, by John Peacock

p4raw-id: //depot/perl@30629

diff --git a/embed.fnc b/embed.fnc
index b9d46a2..1686b3c 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -599,7 +599,7 @@ Apa |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems
 Ap     |char*  |scan_vstring   |NN const char *vstr|NN SV *sv
 Apd    |const char*    |scan_version   |NN const char *vstr|NN SV *sv|bool qv
 Apd    |SV*    |new_version    |NN SV *ver
-Apd    |SV*    |upg_version    |NN SV *ver
+Apd    |SV*    |upg_version    |NN SV *ver|bool qv
 Apd    |bool   |vverify        |NN SV *vs
 Apd    |SV*    |vnumify        |NN SV *vs
 Apd    |SV*    |vnormal        |NN SV *vs

diff --git a/embed.h b/embed.h
index 78d4b56..c930c91 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -2813,7 +2813,7 @@
 #define scan_vstring(a,b)      Perl_scan_vstring(aTHX_ a,b)
 #define scan_version(a,b,c)    Perl_scan_version(aTHX_ a,b,c)
 #define new_version(a)         Perl_new_version(aTHX_ a)
-#define upg_version(a)         Perl_upg_version(aTHX_ a)
+#define upg_version(a,b)       Perl_upg_version(aTHX_ a,b)
 #define vverify(a)             Perl_vverify(aTHX_ a)
 #define vnumify(a)             Perl_vnumify(aTHX_ a)
 #define vnormal(a)             Perl_vnormal(aTHX_ a)

diff --git a/gv.c b/gv.c
index 26308bb..f48ef98 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1287,7 +1287,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
        {
            SV * const sv = GvSVn(gv);
            if (!sv_derived_from(PL_patchlevel, "version"))
-               upg_version(PL_patchlevel);
+               upg_version(PL_patchlevel, TRUE);
            GvSV(gv) = vnumify(PL_patchlevel);
            SvREADONLY_on(GvSV(gv));
            SvREFCNT_dec(sv);

diff --git a/lib/version.t b/lib/version.t
index 2438a30..11a6b07 100644 (file)
--- a/lib/version.t
+++ b/lib/version.t
@@ -400,8 +400,8 @@ SKIP: {
     }
 
 SKIP:  {
-       skip 'Cannot test bare v-strings with Perl < 5.8.1', 4
-               if $] < 5.008_001; 
+       skip 'Cannot test bare v-strings with Perl < 5.6.0', 4
+               if $] < 5.006_000; 
        diag "Tests with v-strings" if $Verbose;
        $version = $CLASS->new(1.2.3);
        ok("$version" eq "v1.2.3", '"$version" eq 1.2.3');
@@ -468,26 +468,26 @@ EOF
        close F;
 
        eval "use lib '.'; use www 0.000008;";
-       like ($@, qr/^www version 0.000008 \(v0.0.8\) required/,
+       like ($@, qr/^www version 0.000008 required/,
            "Make sure very small versions don't freak"); 
        eval "use lib '.'; use www 1;";
-       like ($@, qr/^www version 1.000 \(v1.0.0\) required/,
+       like ($@, qr/^www version 1.000 required/,
            "Comparing vs. version with no decimal"); 
        eval "use lib '.'; use www 1.;";
-       like ($@, qr/^www version 1.000 \(v1.0.0\) required/,
+       like ($@, qr/^www version 1.000 required/,
            "Comparing vs. version with decimal only"); 
 
-       if ( $] < 5.006_002 ) {
+       if ( $] < 5.006_000 ) {
            unlink 'www.pm';
-           skip 'Cannot "use" extended versions with Perl < 5.6.2', 3; 
+           skip 'Cannot "use" extended versions with Perl < 5.6.0', 3; 
        }
-       eval "use lib '.'; use www 0.0.8;";
-       like ($@, qr/^www version 0.000008 \(v0.0.8\) required/,
-           "Make sure very small versions don't freak"); 
+       eval "use lib '.'; use www v0.0.8;";
+       my $regex = "^www version v0.0.8 required";
+       like ($@, qr/$regex/, "Make sure very small versions don't freak"); 
 
-       eval "use lib '.'; use www 0.0.4;";
-       unlike($@, qr/^www version 0.000004 \(v0.0.4\) required/,
-           'Succeed - required == VERSION');
+       $regex =~ s/8/4/; # set for second test
+       eval "use lib '.'; use www v0.0.4;";
+       unlike($@, qr/$regex/, 'Succeed - required == VERSION');
        cmp_ok ( "www"->VERSION, 'eq', '0.000004', 'No undef warnings' );
 
        unlink 'www.pm';
@@ -509,6 +509,26 @@ EOF
     unlink 'vvv.pm';
 
 SKIP: {
+       if ( $] < 5.006_000 ) {
+           skip 'Cannot "use" extended versions with Perl < 5.6.0', 3; 
+       }
+       open F, ">uuu.pm" or die "Cannot open uuu.pm: $!\n";
+       print F <<"EOF";
+package uuu;
+\$VERSION = 1.0;
+1;
+EOF
+       close F;
+       eval "use lib '.'; use uuu 1.001;";
+       like ($@, qr/^uuu version 1.001 required/,
+           "User typed numeric so we error with numeric"); 
+       eval "use lib '.'; use uuu v1.1.0;";
+       like ($@, qr/^uuu version v1.1.0 required/,
+           "User typed extended so we error with extended"); 
+       unlink 'uuu.pm';
+    }
+
+SKIP: {
        # test locale handling
        my $warning;
        local $SIG{__WARN__} = sub { $warning = $_[0] };
@@ -534,6 +554,7 @@ SKIP: {
     eval 'my $v = $CLASS->new("1._1");';
     unlike($@, qr/^Invalid version format \(alpha with zero width\)/,
        "Invalid version format 1._1");
+
 }
 
 1;

diff --git a/perl.c b/perl.c
index 3090375..982ec89 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -3279,7 +3279,7 @@ Perl_moreswitches(pTHX_ char *s)
        return s;
     case 'v':
        if (!sv_derived_from(PL_patchlevel, "version"))
-           upg_version(PL_patchlevel);
+           upg_version(PL_patchlevel, TRUE);
 #if !defined(DGUX)
        PerlIO_printf(PerlIO_stdout(),
                Perl_form(aTHX_ "\nThis is perl, %"SVf

diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index 3f0adf1..7f82d8b 100644 (file)
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -2656,11 +2656,12 @@ X<upg_version>
 
 In-place upgrade of the supplied SV to a version object.
 
-    SV *sv = upg_version(SV *sv);
+    SV *sv = upg_version(SV *sv, bool qv);
 
-Returns a pointer to the upgraded SV.
+Returns a pointer to the upgraded SV.  Set the boolean qv if you want
+to force this SV to be interpreted as an "extended" version.
 
-       SV*     upg_version(SV *ver)
+       SV*     upg_version(SV *ver, bool qv)
 
 =for hackers
 Found in file util.c

diff --git a/pp_ctl.c b/pp_ctl.c
index f818869..25cfe5f 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3089,7 +3089,7 @@ PP(pp_require)
 
        sv = new_version(sv);
        if (!sv_derived_from(PL_patchlevel, "version"))
-           upg_version(PL_patchlevel);
+           upg_version(PL_patchlevel, TRUE);
        if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
            if ( vcmp(sv,PL_patchlevel) <= 0 )
                DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
@@ -3104,7 +3104,7 @@ PP(pp_require)
        /* If we request a version >= 5.9.5, load feature.pm with the
         * feature bundle that corresponds to the required version.
         * We do this only with use, not require. */
-       if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005)))) >= 0) {
+       if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
            SV *const importsv = vnormal(sv);
            *SvPVX_mutable(importsv) = ':';
            ENTER;

diff --git a/proto.h b/proto.h
index 25dc06a..54c98f4 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1674,7 +1674,7 @@ PERL_CALLCONV const char* Perl_scan_version(pTHX_ const char *vstr, SV *sv, bool
 PERL_CALLCONV SV*      Perl_new_version(pTHX_ SV *ver)
                        __attribute__nonnull__(pTHX_1);
 
-PERL_CALLCONV SV*      Perl_upg_version(pTHX_ SV *ver)
+PERL_CALLCONV SV*      Perl_upg_version(pTHX_ SV *ver, bool qv)
                        __attribute__nonnull__(pTHX_1);
 
 PERL_CALLCONV bool     Perl_vverify(pTHX_ SV *vs)

diff --git a/t/comp/use.t b/t/comp/use.t
index a6ea3e6..9df08d2 100755 (executable)
--- a/t/comp/use.t
+++ b/t/comp/use.t
@@ -139,39 +139,39 @@ if ($^O eq 'MacOS') {
     is ($@, '');
 
     eval "use lib v100.105";
-    like ($@, qr/lib version 100.105 \(v100\.105\.0\) required--this is only version 35.360 \(v35\.360\.0\)/);
+    like ($@, qr/lib version v100.105.0 required--this is only version v35\.360\.0/);
 
     eval "use lib 33.55";
     is ($@, '');
 
     eval "use lib 100.105";
-    like ($@, qr/lib version 100.105 \(v100\.105\.0\) required--this is only version 35.360 \(v35\.360\.0\)/);
+    like ($@, qr/lib version 100.105 required--this is only version 35.360/);
 
     local $lib::VERSION = '35.36';
     eval "use lib v33.55";
     like ($@, '');
 
     eval "use lib v100.105";
-    like ($@, qr/lib version 100.105 \(v100\.105\.0\) required--this is only version 35.360 \(v35\.360\.0\)/);
+    like ($@, qr/lib version v100.105.0 required--this is only version v35\.360\.0/);
 
     eval "use lib 33.55";
     is ($@, '');
 
     eval "use lib 100.105";
-    like ($@, qr/lib version 100.105 \(v100\.105\.0\) required--this is only version 35.360 \(v35\.360\.0\)/);
+    like ($@, qr/lib version 100.105 required--this is only version 35.360/);
 
     local $lib::VERSION = v35.36;
     eval "use lib v33.55";
     is ($@, '');
 
     eval "use lib v100.105";
-    like ($@, qr/lib version 100.105 \(v100\.105\.0\) required--this is only version 35.036000 \(v35\.36\.0\)/);
+    like ($@, qr/lib version v100.105.0 required--this is only version v35\.36\.0/);
 
     eval "use lib 33.55";
     is ($@, '');
 
     eval "use lib 100.105";
-    like ($@, qr/lib version 100.105 \(v100\.105\.0\) required--this is only version 35.036000 \(v35\.36\.0\)/);
+    like ($@, qr/lib version 100.105 required--this is only version 35.036000/);
 }
 
 

diff --git a/t/op/universal.t b/t/op/universal.t
index 5e7fb1e..69067e8 100755 (executable)
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -114,7 +114,7 @@ ok ! $a->can("export_tags");        # a method in Exporter
 cmp_ok eval { $a->VERSION }, '==', 2.718;
 
 ok ! (eval { $a->VERSION(2.719) });
-like $@, qr/^Alice version 2.719 \(v2\.719\.0\) required--this is only version 2.718 \(v2\.718\.0\) at /;
+like $@, qr/^Alice version 2.719 required--this is only version 2.718 at /;
 
 ok (eval { $a->VERSION(2.718) });
 is $@, '';

diff --git a/universal.c b/universal.c
index 69c31f1..0d2ec1c 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -457,7 +457,7 @@ XS(XS_UNIVERSAL_VERSION)
         sv_setsv(nsv, sv);
         sv = nsv;
        if ( !sv_derived_from(sv, "version"))
-           upg_version(sv);
+           upg_version(sv, FALSE);
         undef = NULL;
     }
     else {
@@ -483,19 +483,23 @@ XS(XS_UNIVERSAL_VERSION)
 
        if ( !sv_derived_from(req, "version")) {
            /* req may very well be R/O, so create a new object */
-           SV * const nsv = sv_newmortal();
-           sv_setsv(nsv, req);
-           req = nsv;
-           upg_version(req);
+           req = sv_2mortal( new_version(req) );
        }
 
-       if ( vcmp( req, sv ) > 0 )
-           Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--"
-                      "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg),
-                      SVfARG(vnumify(req)),
+       if ( vcmp( req, sv ) > 0 ) {
+           if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) {
+               Perl_croak(aTHX_ "%s version %"SVf" required--"
+                      "this is only version %"SVf"", HvNAME_get(pkg),
                       SVfARG(vnormal(req)),
-                      SVfARG(vnumify(sv)),
                       SVfARG(vnormal(sv)));
+           } else {
+               Perl_croak(aTHX_ "%s version %"SVf" required--"
+                      "this is only version %"SVf"", HvNAME_get(pkg),
+                      SVfARG(vnumify(req)),
+                      SVfARG(vnumify(sv)));
+           }
+       }
+
     }
 
     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
@@ -728,29 +732,10 @@ XS(XS_version_qv)
     {
        SV *    ver = ST(0);
        if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
-           SV * const vs = sv_newmortal();
-           char *version;
-           if ( SvNOK(ver) ) /* may get too much accuracy */
-           {
-               char tbuf[64];
-#ifdef USE_LOCALE_NUMERIC
-               char *loc = setlocale(LC_NUMERIC, "C");
-#endif
-               STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver));
-#ifdef USE_LOCALE_NUMERIC
-               setlocale(LC_NUMERIC, loc);
-#endif
-               while (tbuf[len-1] == '0' && len > 0) len--;
-               version = savepvn(tbuf, len);
-           }
-           else
-           {
-               version = savesvpv(ver);
-           }
-           (void)scan_version(version,vs,TRUE);
-           Safefree(version);
-
-           PUSHs(vs);
+           SV * const rv = sv_newmortal();
+           sv_setsv(rv,ver); /* make a duplicate */
+           upg_version(rv, TRUE);
+           PUSHs(rv);
        }
        else
        {

diff --git a/util.c b/util.c
index c25402f..5a95d68 100644 (file)
--- a/util.c
+++ b/util.c
@@ -4326,7 +4326,7 @@ Perl_new_version(pTHX_ SV *ver)
        }
     }
 #endif
-    return upg_version(rv);
+    return upg_version(rv, FALSE);
 }
 
 /*
@@ -4334,24 +4334,25 @@ Perl_new_version(pTHX_ SV *ver)
 
 In-place upgrade of the supplied SV to a version object.
 
-    SV *sv = upg_version(SV *sv);
+    SV *sv = upg_version(SV *sv, bool qv);
 
-Returns a pointer to the upgraded SV.
+Returns a pointer to the upgraded SV.  Set the boolean qv if you want
+to force this SV to be interpreted as an "extended" version.
 
 =cut
 */
 
 SV *
-Perl_upg_version(pTHX_ SV *ver)
+Perl_upg_version(pTHX_ SV *ver, bool qv)
 {
     const char *version, *s;
-    bool qv = 0;
 #ifdef SvVOK
     const MAGIC *mg;
 #endif
 
-    if ( SvNOK(ver) ) /* may get too much accuracy */ 
+    if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
     {
+       /* may get too much accuracy */ 
        char tbuf[64];
 #ifdef USE_LOCALE_NUMERIC
        char *loc = setlocale(LC_NUMERIC, "C");
@@ -4371,7 +4372,35 @@ Perl_upg_version(pTHX_ SV *ver)
 #endif
     else /* must be a string or something like a string */
     {
-       version = savepv(SvPV_nolen(ver));
+       STRLEN len;
+       version = savepv(SvPV(ver,len));
+#ifndef SvVOK
+#  if PERL_VERSION > 5
+       /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
+       if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
+           /* may be a v-string */
+           SV * const nsv = sv_newmortal();
+           const char *nver;
+           const char *pos;
+           int saw_period = 0;
+           sv_setpvf(nsv,"%vd",ver);
+           pos = nver = savepv(SvPV_nolen(nsv));
+
+           /* scan the resulting formatted string */
+           while ( *pos == '.' || isDIGIT(*pos) ) {
+               if ( *pos == '.' )
+                   saw_period++ ;
+               pos++;
+           }
+
+           /* is definitely a v-string */
+           if ( saw_period == 2 ) {    
+               Safefree(version);
+               version = nver;
+           }
+       }
+#  endif
+#endif
     }
 
     s = scan_version(version, ver, qv);