Bring core Perl in line with CPAN 0.86 release

Attached is a patch that bring the core Perl version code inline with
the latest CPAN release.  The vast majority of changes are in code that
does not execute in core, but that makes it easier to keep the core and
CPAN changes in sync.

diff --git a/lib/version.pm b/lib/version.pm
index 405eb10..b07cb77 100644 (file)
--- a/lib/version.pm
+++ b/lib/version.pm
@@ -6,7 +6,7 @@ use strict;
 
 use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
 
-$VERSION = 0.82;
+$VERSION = 0.86;
 
 $CLASS = 'version';
 
@@ -157,11 +157,13 @@ sub import {
     }
 
     if (exists($args{'is_strict'})) {
-       *{$callpkg.'::is_strict'} = \&version::is_strict;
+       *{$callpkg.'::is_strict'} = \&version::is_strict
+         unless defined(&{$callpkg.'::is_strict'});
     }
 
     if (exists($args{'is_lax'})) {
-       *{$callpkg.'::is_lax'} = \&version::is_lax;
+       *{$callpkg.'::is_lax'} = \&version::is_lax
+         unless defined(&{$callpkg.'::is_lax'});
     }
 }
 

diff --git a/lib/version.t b/lib/version.t
index da7a5fd..23ad2c9 100644 (file)
--- a/lib/version.t
+++ b/lib/version.t
@@ -201,15 +201,15 @@ sub BaseTests {
     
     # test illegal formats
     diag "test illegal formats" unless $ENV{PERL_CORE};
-    eval {$version = $CLASS->$method("1.2_3_4")};
+    eval {my $version = $CLASS->$method("1.2_3_4")};
     like($@, qr/multiple underscores/,
        "Invalid version format (multiple underscores)");
     
-    eval {$version = $CLASS->$method("1.2_3.4")};
+    eval {my $version = $CLASS->$method("1.2_3.4")};
     like($@, qr/underscores before decimal/,
        "Invalid version format (underscores before decimal)");
     
-    eval {$version = $CLASS->$method("1_2")};
+    eval {my $version = $CLASS->$method("1_2")};
     like($@, qr/alpha without decimal/,
        "Invalid version format (alpha without decimal)");
     
@@ -353,7 +353,7 @@ SKIP: {
     ok (eval {$new_version = $CLASS->$method($version)},
            "new from existing object");
     ok ($new_version == $version, "class->$method($version) identical");
-    $new_version = $version->$method();
+    $new_version = $version->$method(0);
     isa_ok ($new_version, $CLASS );
     is ($new_version, "0", "version->$method() doesn't clone");
     $new_version = $version->$method("1.2.3");
@@ -480,14 +480,24 @@ SKIP:     {
                if $] < 5.006_000; 
        diag "Tests with v-strings" unless $ENV{PERL_CORE};
        $version = $CLASS->$method(1.2.3);
-       ok("$version" == "v1.2.3", '"$version" == 1.2.3');
+       ok("$version" eq "v1.2.3", '"$version" eq 1.2.3');
        $version = $CLASS->$method(1.0.0);
        $new_version = $CLASS->$method(1);
        ok($version == $new_version, '$version == $new_version');
        skip "version require'd instead of use'd, cannot test declare", 1
            unless defined $qv_declare;
        $version = &$qv_declare(1.2.3);
-       ok("$version" == "v1.2.3", 'v-string initialized $qv_declare()');
+       ok("$version" eq "v1.2.3", 'v-string initialized $qv_declare()');
+    }
+
+SKIP:  {
+       skip 'Cannot test bare alpha v-strings with Perl < 5.8.1', 2
+               if $] lt 5.008_001; 
+       diag "Tests with bare alpha v-strings" unless $ENV{PERL_CORE};
+       $version = $CLASS->$method(v1.2.3_4);
+       is($version, "v1.2.3_4", '"$version" eq "v1.2.3_4"');
+       $version = $CLASS->$method(eval "v1.2.3_4");
+       is($version, "v1.2.3_4", '"$version" eq "v1.2.3_4" (from eval)');
     }
 
     diag "Tests with real-world (malformed) data" unless $ENV{PERL_CORE};
@@ -690,6 +700,28 @@ EOF
        my $badv2 = bless { qv => 1, version => [1,2,3] }, "version";
        is $badv2, 'v1.2.3', "Deal with badly serialized versions from YAML ";  
     }
+SKIP: {
+       if ( $] < 5.006_000 ) {
+           skip 'No v-string support at all < 5.6.0', 2; 
+       }
+       # https://rt.cpan.org/Ticket/Display.html?id=49348
+       my $v = $CLASS->$method("420");
+       is "$v", "420", 'Correctly guesses this is not a v-string';
+       $v = $CLASS->$method(4.2.0);
+       is "$v", 'v4.2.0', 'Correctly guess that this is a v-string';
+    }
+SKIP: {
+       if ( $] < 5.006_000 ) {
+           skip 'No v-string support at all < 5.6.0', 4; 
+       }
+       # https://rt.cpan.org/Ticket/Display.html?id=50347
+       # Check that the qv() implementation does not change
+
+       ok $CLASS->$method(1.2.3) < $CLASS->$method(1.2.3.1), 'Compare 3 and 4 digit v-strings' ;
+       ok $CLASS->$method(v1.2.3) < $CLASS->$method(v1.2.3.1), 'Compare 3 and 4 digit v-strings, leaving v';
+       ok $CLASS->$method("1.2.3") < $CLASS->$method("1.2.3.1"), 'Compare 3 and 4 digit v-strings, quoted';
+       ok $CLASS->$method("v1.2.3") < $CLASS->$method("v1.2.3.1"), 'Compare 3 and 4 digit v-strings, quoted leading v';
+    }
 }
 
 1;

diff --git a/util.c b/util.c
index 52554be..f3c27f9 100644 (file)
--- a/util.c
+++ b/util.c
@@ -4534,6 +4534,11 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 /*
 =for apidoc prescan_version
 
+Validate that a given string can be parsed as a version object, but doesn't
+actually perform the parsing.  Can use either strict or lax validation rules.
+Can optionally set a number of hint variables to save the parsing code
+some time when tokenizing.
+
 =cut
 */
 const char *
@@ -5067,29 +5072,35 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 #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,"_")
-           && !(*version == 'u' && strEQ(version, "undef"))
-           && (*version < '0' || *version > '9') ) {
+       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_decimal = 0;
-           sv_setpvf(nsv,"v%vd",ver);
-           pos = nver = savepv(SvPV_nolen(nsv));
-
-           /* scan the resulting formatted string */
-           pos++; /* skip the leading 'v' */
-           while ( *pos == '.' || isDIGIT(*pos) ) {
-               if ( *pos == '.' )
-                   saw_decimal++ ;
-               pos++;
-           }
+           char *testv = (char *)version;
+           STRLEN tlen = len;
+           for (tlen=0; tlen < len; tlen++, testv++) {
+               /* if one of the characters is non-text assume v-string */
+               if (testv[0] < ' ') {
+                   SV * const nsv = sv_newmortal();
+                   const char *nver;
+                   const char *pos;
+                   int saw_decimal = 0;
+                   sv_setpvf(nsv,"v%vd",ver);
+                   pos = nver = savepv(SvPV_nolen(nsv));
+
+                   /* scan the resulting formatted string */
+                   pos++; /* skip the leading 'v' */
+                   while ( *pos == '.' || isDIGIT(*pos) ) {
+                       if ( *pos == '.' )
+                           saw_decimal++ ;
+                       pos++;
+                   }
 
-           /* is definitely a v-string */
-           if ( saw_decimal >= 2 ) {
-               Safefree(version);
-               version = nver;
+                   /* is definitely a v-string */
+                   if ( saw_decimal >= 2 ) {   
+                       Safefree(version);
+                       version = nver;
+                   }
+                   break;
+               }
            }
        }
 #  endif