Sync core with CPAN version.pm release

Remove pointless diag lines, which were more trouble than they were
worth.  Add code to ensure that SV's with magic are handled properly,
and include a test for it as well.  A couple of whitespace changes and
one last set of I32 -> SSize_t upgrade for array indices.

diff --git a/cpan/version/lib/version.pm b/cpan/version/lib/version.pm
index 7b9d645..1e86ac2 100644 (file)
--- a/cpan/version/lib/version.pm
+++ b/cpan/version/lib/version.pm
@@ -6,7 +6,7 @@ use strict;
 
 use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
 
-$VERSION = 0.9903;
+$VERSION = 0.9904;
 
 $CLASS = 'version';
 

diff --git a/cpan/version/t/01base.t b/cpan/version/t/01base.t
index e6df81a..7e83058 100644 (file)
--- a/cpan/version/t/01base.t
+++ b/cpan/version/t/01base.t
@@ -5,16 +5,13 @@
 #########################
 
 use Test::More qw/no_plan/;
-our $Verbose;
 
 BEGIN {
     (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
     require $coretests;
-    use_ok('version', 0.9903);
+    use_ok('version', 0.9904);
 }
 
-diag "Tests with base class" if $Verbose;
-
 BaseTests("version","new","qv");
 BaseTests("version","new","declare");
 BaseTests("version","parse", "qv");

diff --git a/cpan/version/t/02derived.t b/cpan/version/t/02derived.t
index afdf531..6ed9524 100644 (file)
--- a/cpan/version/t/02derived.t
+++ b/cpan/version/t/02derived.t
@@ -6,12 +6,11 @@
 
 use Test::More qw/no_plan/;
 use File::Temp qw/tempfile/;
-our $Verbose;
 
 BEGIN {
     (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
     require $coretests;
-    use_ok("version", 0.9903);
+    use_ok("version", 0.9904);
     # If we made it this far, we are ok.
 }
 
@@ -58,8 +57,6 @@ sub main_reset {
     undef &declare; undef *::declare; # avoid 'used once' warning
 }
 
-diag "Tests with empty derived class"  if $Verbose;
-
 use_ok($package, 0.001);
 my $testobj = $package->new(1.002_003);
 isa_ok( $testobj, $package );
@@ -81,7 +78,6 @@ main_reset;
 use_ok($package, 0.001, "declare");
 BaseTests($package, "parse", "declare");
 
-diag "tests with bad subclass"  if $Verbose;
 $testobj = version::Bad->new(1.002_003);
 isa_ok( $testobj, "version::Bad" );
 eval { my $string = $testobj->numify };

diff --git a/cpan/version/t/03require.t b/cpan/version/t/03require.t
index 316ea24..d579579 100644 (file)
--- a/cpan/version/t/03require.t
+++ b/cpan/version/t/03require.t
@@ -5,7 +5,6 @@
 #########################
 
 use Test::More qw/no_plan/;
-our $Verbose;
 
 BEGIN {
     (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
@@ -15,12 +14,9 @@ BEGIN {
 # Don't want to use, because we need to make sure that the import doesn't
 # fire just yet (some code does this to avoid importing qv() and delare()).
 require_ok("version");
-is $version::VERSION, 0.9903, "Make sure we have the correct class";
+is $version::VERSION, 0.9904, "Make sure we have the correct class";
 ok(!"main"->can("qv"), "We don't have the imported qv()");
 ok(!"main"->can("declare"), "We don't have the imported declare()");
 
-
-diag "Tests with base class" if $Verbose;
-
 BaseTests("version","new",undef);
 BaseTests("version","parse",undef);

diff --git a/cpan/version/t/05sigdie.t b/cpan/version/t/05sigdie.t
index bcc0776..bac5534 100644 (file)
--- a/cpan/version/t/05sigdie.t
+++ b/cpan/version/t/05sigdie.t
@@ -13,9 +13,8 @@ BEGIN {
     };
 }
 
-
 BEGIN {
-    use version 0.9903;
+    use version 0.9904;
 }
 
 pass "Didn't get caught by the wrong DIE handler, which is a good thing";

diff --git a/cpan/version/t/06noop.t b/cpan/version/t/06noop.t
index 2f15b39..e26532f 100644 (file)
--- a/cpan/version/t/06noop.t
+++ b/cpan/version/t/06noop.t
@@ -7,7 +7,7 @@
 use Test::More qw/no_plan/;
 
 BEGIN {
-    use_ok('version', 0.9903);
+    use_ok('version', 0.9904);
 }
 
 my $v1 = version->new('1.2');

diff --git a/cpan/version/t/07locale.t b/cpan/version/t/07locale.t
index ab2affc..93662ed 100644 (file)
--- a/cpan/version/t/07locale.t
+++ b/cpan/version/t/07locale.t
@@ -9,10 +9,9 @@ use File::Temp qw/tempfile/;
 use POSIX qw/locale_h/;
 use Test::More tests => 7;
 use Config;
-our $Verbose;
 
 BEGIN {
-    use_ok('version', 0.9903);
+    use_ok('version', 0.9904);
 }
 
 SKIP: {
@@ -42,8 +41,6 @@ SKIP: {
        skip 'Cannot test locale handling without a comma locale', 5
            unless $loc and localeconv()->{decimal_point} eq ',';
 
-       diag ("Testing locale handling with $loc") if $Verbose;
-
        setlocale(LC_NUMERIC, $loc);
        ok ($ver eq "1,23", "Using locale: $loc");
        $v = version->new($ver);

diff --git a/cpan/version/t/08_corelist.t b/cpan/version/t/08_corelist.t
new file mode 100644 (file)
index 0000000..5e548a9
--- /dev/null
+++ b/cpan/version/t/08_corelist.t
@@ -0,0 +1,20 @@
+#! /usr/local/perl -w
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+#########################
+
+use Test::More tests => 2;
+use_ok("version", 0.9904);
+
+# do strict lax tests in a sub to isolate a package to test importing
+SKIP: {
+    eval "use Module::CoreList 2.76";
+    skip 'No tied hash in Modules::CoreList in Perl', 1
+       if $@;
+
+    my $foo = version->parse($Module::CoreList::version{5.008_000}{base});
+
+    is $foo, $Module::CoreList::version{5.008_000}{base},
+       'Correctly handle tied hash';
+}

diff --git a/cpan/version/t/coretests.pm b/cpan/version/t/coretests.pm
index df1984a..080b6ae 100644 (file)
--- a/cpan/version/t/coretests.pm
+++ b/cpan/version/t/coretests.pm
@@ -1,8 +1,6 @@
 #! /usr/local/perl -w
 package main;
 require Test::Harness;
-*Verbose = \$Test::Harness::Verbose;
-$Verbose = 0 if $ENV{PERL_CORE};
 use Data::Dumper;
 use File::Temp qw/tempfile/;
 use File::Basename;
@@ -27,21 +25,18 @@ sub BaseTests {
     # its man page ( perldoc Test ) for help writing this test script.
 
     # Test bare number processing
-    diag "tests with bare numbers" if $Verbose;
     $version = $CLASS->$method(5.005_03);
     is ( "$version" , "5.00503" , '5.005_03 eq 5.00503' );
     $version = $CLASS->$method(1.23);
     is ( "$version" , "1.23" , '1.23 eq "1.23"' );
 
     # Test quoted number processing
-    diag "tests with quoted numbers" if $Verbose;
     $version = $CLASS->$method("5.005_03");
     is ( "$version" , "5.005_03" , '"5.005_03" eq "5.005_03"' );
     $version = $CLASS->$method("v1.23");
     is ( "$version" , "v1.23" , '"v1.23" eq "v1.23"' );
 
     # Test stringify operator
-    diag "tests with stringify" if $Verbose;
     $version = $CLASS->$method("5.005");
     is ( "$version" , "5.005" , '5.005 eq "5.005"' );
     $version = $CLASS->$method("5.006.001");
@@ -51,7 +46,6 @@ sub BaseTests {
     is ( "$version" , "v1.2.3_4" , 'alpha version 1.2.3_4 eq v1.2.3_4' );
 
     # test illegal formats
-    diag "test illegal formats" if $Verbose;
     eval {my $version = $CLASS->$method("1.2_3_4")};
     like($@, qr/multiple underscores/,
        "Invalid version format (multiple underscores)");
@@ -93,7 +87,6 @@ sub BaseTests {
     isa_ok ( $version, $CLASS );
 
     # Test comparison operators with self
-    diag "tests with self" if $Verbose;
     is ( $version <=> $version, 0, '$version <=> $version == 0' );
     ok ( $version == $version, '$version == $version' );
 
@@ -101,7 +94,6 @@ sub BaseTests {
     # test first with non-object
     $version = $CLASS->$method("5.006.001");
     $new_version = "5.8.0";
-    diag "numeric tests with non-objects" if $Verbose;
     ok ( $version == $version, '$version == $version' );
     ok ( $version < $new_version, '$version < $new_version' );
     ok ( $new_version > $version, '$new_version > $version' );
@@ -109,20 +101,17 @@ sub BaseTests {
 
     # now test with existing object
     $new_version = $CLASS->$method($new_version);
-    diag "numeric tests with objects" if $Verbose;
     ok ( $version < $new_version, '$version < $new_version' );
     ok ( $new_version > $version, '$new_version > $version' );
     ok ( $version != $new_version, '$version != $new_version' );
 
     # now test with actual numbers
-    diag "numeric tests with numbers" if $Verbose;
     ok ( $version->numify() == 5.006001, '$version->numify() == 5.006001' );
     ok ( $version->numify() <= 5.006001, '$version->numify() <= 5.006001' );
     ok ( $version->numify() < 5.008, '$version->numify() < 5.008' );
     #ok ( $version->numify() > v5.005_02, '$version->numify() > 5.005_02' );
 
     # test with long decimals
-    diag "Tests with extended decimal versions" if $Verbose;
     $version = $CLASS->$method(1.002003);
     ok ( $version == "1.2.3", '$version == "1.2.3"');
     ok ( $version->numify == 1.002003, '$version->numify == 1.002003');
@@ -134,14 +123,11 @@ sub BaseTests {
     # now test with alpha version form with string
     $version = $CLASS->$method("1.2.3");
     $new_version = "1.2.3_4";
-    diag "numeric tests with alpha-style non-objects" if $Verbose;
     ok ( $version < $new_version, '$version < $new_version' );
     ok ( $new_version > $version, '$new_version > $version' );
     ok ( $version != $new_version, '$version != $new_version' );
 
     $version = $CLASS->$method("1.2.4");
-    diag "numeric tests with alpha-style non-objects"
-       if $Verbose;
     ok ( $version > $new_version, '$version > $new_version' );
     ok ( $new_version < $version, '$new_version < $version' );
     ok ( $version != $new_version, '$version != $new_version' );
@@ -149,7 +135,6 @@ sub BaseTests {
     # now test with alpha version form with object
     $version = $CLASS->$method("1.2.3");
     $new_version = $CLASS->$method("1.2.3_4");
-    diag "tests with alpha-style objects" if $Verbose;
     ok ( $version < $new_version, '$version < $new_version' );
     ok ( $new_version > $version, '$new_version > $version' );
     ok ( $version != $new_version, '$version != $new_version' );
@@ -157,20 +142,16 @@ sub BaseTests {
     ok ( $new_version->is_alpha, '$new_version->is_alpha');
 
     $version = $CLASS->$method("1.2.4");
-    diag "tests with alpha-style objects" if $Verbose;
     ok ( $version > $new_version, '$version > $new_version' );
     ok ( $new_version < $version, '$new_version < $version' );
     ok ( $version != $new_version, '$version != $new_version' );
 
     $version = $CLASS->$method("1.2.3.4");
     $new_version = $CLASS->$method("1.2.3_4");
-    diag "tests with alpha-style objects with same subversion"
-       if $Verbose;
     ok ( $version > $new_version, '$version > $new_version' );
     ok ( $new_version < $version, '$new_version < $version' );
     ok ( $version != $new_version, '$version != $new_version' );
 
-    diag "test implicit [in]equality" if $Verbose;
     $version = $CLASS->$method("v1.2.3");
     $new_version = $CLASS->$method("1.2.3.0");
     ok ( $version == $new_version, '$version == $new_version' );
@@ -183,7 +164,6 @@ sub BaseTests {
     $new_version = $CLASS->$method("1.1.999");
     ok ( $version > $new_version, '$version > $new_version' );
 
-    diag "test with version class names" if $Verbose;
     $version = $CLASS->$method("v1.2.3");
     eval { () = $version < 'version' };
     # this test, and only this test, I have to do this or else $@ gets
@@ -192,7 +172,6 @@ sub BaseTests {
     like $err, qr/^Invalid version format/, "error with $version < 'version'";
 
     # that which is not expressly permitted is forbidden
-    diag "forbidden operations" if $Verbose;
     ok ( !eval { ++$version }, "noop ++" );
     ok ( !eval { --$version }, "noop --" );
     ok ( !eval { $version/1 }, "noop /" );
@@ -203,7 +182,6 @@ SKIP: {
     skip "version require'd instead of use'd, cannot test $qv_declare", 3
        unless defined $qv_declare;
     # test the $qv_declare() sub
-    diag "testing $qv_declare" if $Verbose;
     $version = $CLASS->$qv_declare("1.2");
     is ( "$version", "v1.2", $qv_declare.'("1.2") == "1.2.0"' );
     $version = $CLASS->$qv_declare(1.2);
@@ -212,7 +190,6 @@ SKIP: {
 }
 
     # test creation from existing version object
-    diag "create new from existing version" if $Verbose;
     ok (eval {$new_version = $CLASS->$method($version)},
            "new from existing object");
     ok ($new_version == $version, "class->$method($version) identical");
@@ -223,21 +200,18 @@ SKIP: {
     is ($new_version, "1.2.3" , '$version->$method("1.2.3") works too');
 
     # test the CVS revision mode
-    diag "testing CVS Revision" if $Verbose;
     $version = new $CLASS qw$Revision: 1.2$;
     ok ( $version == "1.2.0", 'qw$Revision: 1.2$ == 1.2.0' );
     $version = new $CLASS qw$Revision: 1.2.3.4$;
     ok ( $version == "1.2.3.4", 'qw$Revision: 1.2.3.4$ == 1.2.3.4' );
 
     # test the CPAN style reduced significant digit form
-    diag "testing CPAN-style versions" if $Verbose;
     $version = $CLASS->$method("1.23_01");
     is ( "$version" , "1.23_01", "CPAN-style alpha version" );
     ok ( $version > 1.23, "1.23_01 > 1.23");
     ok ( $version < 1.24, "1.23_01 < 1.24");
 
     # test reformed UNIVERSAL::VERSION
-    diag "Replacement UNIVERSAL::VERSION tests" if $Verbose;
 
     my $error_regex = $] < 5.006
        ? 'version \d required'
@@ -355,7 +329,6 @@ SKIP:    { # https://rt.perl.org/rt3/Ticket/Display.html?id=95544
 SKIP:  {
        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->$method(1.2.3);
        ok("$version" eq "v1.2.3", '"$version" eq 1.2.3');
        $version = $CLASS->$method(1.0.0);
@@ -370,15 +343,12 @@ SKIP:     {
 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" if $Verbose;
        $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" if $Verbose;
-
     # trailing zero testing (reported by Andreas Koenig).
     $version = $CLASS->$method("1");
     ok($version->numify eq "1.000", "trailing zeros preserved");

diff --git a/universal.c b/universal.c
index 847de55..8337e2b 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -508,6 +508,10 @@ XS(XS_version_new)
         STRLEN len;
         const char *classname;
         U32 flags;
+
+       /* Just in case this is something like a tied hash */
+       SvGETMAGIC(vs);
+
         if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
             const HV * stash = SvSTASH(SvRV(ST(0)));
             classname = HvNAME(stash);
@@ -725,8 +729,14 @@ XS(XS_version_qv)
         STRLEN len = 0;
         const char * classname = "";
         U32 flags = 0;
-        if ( items == 2 && SvOK(ST(1)) ) {
-            ver = ST(1);
+        if ( items == 2 ) {
+           SvGETMAGIC(ST(1));
+           if (SvOK(ST(1))) {
+               ver = ST(1);
+           }
+           else {
+               Perl_croak(aTHX_ "Invalid version format (version required)");
+           }
             if ( sv_isobject(ST(0)) ) { /* class called as an object method */
                 const HV * stash = SvSTASH(SvRV(ST(0)));
                 classname = HvNAME(stash);

diff --git a/util.c b/util.c
index 0cd99f3..a2c2513 100644 (file)
--- a/util.c
+++ b/util.c
@@ -4468,10 +4468,10 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
        char *buf;
 #ifdef USE_LOCALE_NUMERIC
        char *loc = NULL;
-        if (! PL_numeric_standard) {
-            loc = savepv(setlocale(LC_NUMERIC, NULL));
-            setlocale(LC_NUMERIC, "C");
-        }
+       if (! PL_numeric_standard) {
+           loc = savepv(setlocale(LC_NUMERIC, NULL));
+           setlocale(LC_NUMERIC, "C");
+       }
 #endif
        if (sv) {
            Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
@@ -4482,10 +4482,10 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
            buf = tbuf;
        }
 #ifdef USE_LOCALE_NUMERIC
-        if (loc) {
-            setlocale(LC_NUMERIC, loc);
-            Safefree(loc);
-        }
+       if (loc) {
+           setlocale(LC_NUMERIC, loc);
+           Safefree(loc);
+       }
 #endif
        while (buf[len-1] == '0' && len > 0) len--;
        if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
@@ -4792,7 +4792,7 @@ converted into version objects.
 int
 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
 {
-    I32 i,l,m,r;
+    SSize_t i,l,m,r;
     I32 retval;
     bool lalpha = FALSE;
     bool ralpha = FALSE;