This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Sync up tests with upstream version.pm
[perl5.git] / lib / version.t
index 8067f1a..0284643 100644 (file)
@@ -1,8 +1,4 @@
 #! /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 qw(no_plan);
 use Data::Dumper;
@@ -27,7 +23,7 @@ BaseTests("version","new","declare");
 BaseTests("version","parse", "qv");
 BaseTests("version","parse", "declare");
 
-# dummy up a redundant call to satify David Wheeler
+# dummy up a redundant call to satisfy David Wheeler
 local $SIG{__WARN__} = sub { die $_[0] };
 eval 'use version;';
 unlike ($@, qr/^Subroutine main::declare redefined/,
@@ -97,6 +93,75 @@ eval { my $test = ($testobj > 1.0) };
 like($@, qr/Invalid version object/,
     "Bad subclass vcmp");
 
+# Invalid structure
+eval { $a = \\version->new(1); bless $a, "version"; print "# $a\n" };
+like($@, qr/Invalid version object/,
+    "Bad internal structure (RT#78286)");
+
+# do strict lax tests in a sub to isolate a package to test importing
+strict_lax_tests();
+
+sub strict_lax_tests {
+  package temp12345;
+  # copied from perl core test t/op/packagev.t
+  # format: STRING STRICT_OK LAX_OK
+  my $strict_lax_data = << 'CASE_DATA';
+1.00           pass    pass
+1.00001                pass    pass
+0.123          pass    pass
+12.345         pass    pass
+42             pass    pass
+0              pass    pass
+0.0            pass    pass
+v1.2.3         pass    pass
+v1.2.3.4       pass    pass
+v0.1.2         pass    pass
+v0.0.0         pass    pass
+01             fail    pass
+01.0203                fail    pass
+v01            fail    pass
+v01.02.03      fail    pass
+.1             fail    pass
+.1.2           fail    pass
+1.             fail    pass
+1.a            fail    fail
+1._            fail    fail
+1.02_03                fail    pass
+v1.2_3         fail    pass
+v1.02_03       fail    pass
+v1.2_3_4       fail    fail
+v1.2_3.4       fail    fail
+1.2_3.4                fail    fail
+0_             fail    fail
+1_             fail    fail
+1_.            fail    fail
+1.1_           fail    fail
+1.02_03_04     fail    fail
+1.2.3          fail    pass
+v1.2           fail    pass
+v0             fail    pass
+v1             fail    pass
+v.1.2.3                fail    fail
+v              fail    fail
+v1.2345.6      fail    pass
+undef          fail    pass
+1a             fail    fail
+1.2a3          fail    fail
+bar            fail    fail
+_              fail    fail
+CASE_DATA
+
+  require version;
+  version->import( qw/is_strict is_lax/ );
+  for my $case ( split qr/\n/, $strict_lax_data ) {
+    my ($v, $strict, $lax) = split qr/\t+/, $case;
+    main::ok( $strict eq 'pass' ? is_strict($v) : ! is_strict($v), "is_strict($v) [$strict]" );
+    main::ok( $strict eq 'pass' ? version::is_strict($v) : ! version::is_strict($v), "version::is_strict($v) [$strict]" );
+    main::ok( $lax eq 'pass' ? is_lax($v) : ! is_lax($v), "is_lax($v) [$lax]" );
+    main::ok( $lax eq 'pass' ? version::is_lax($v) : ! version::is_lax($v), "version::is_lax($v) [$lax]" );
+  }
+}
+
 sub BaseTests {
 
     my ($CLASS, $method, $qv_declare) = @_;
@@ -144,31 +209,24 @@ sub BaseTests {
     like($@, qr/alpha without decimal/,
        "Invalid version format (alpha without decimal)");
     
-    # for this test, upgrade the warn() to die()
-    eval {
-       local $SIG{__WARN__} = sub { die $_[0] };
-       $version = $CLASS->$method("1.2b3");
-    };
-    my $warnregex = "Version string '.+' contains invalid data; ".
-           "ignoring: '.+'";
+    eval { $version = $CLASS->$method("1.2b3")};
+    like($@, qr/non-numeric data/,
+       "Invalid version format (non-numeric data)");
 
-    like($@, qr/$warnregex/,
-       "Version string contains invalid data; ignoring");
+    eval { $version = $CLASS->$method("-1.23")};
+    like($@, qr/negative version number/,
+       "Invalid version format (negative version number)");
 
     # from here on out capture the warning and test independently
     {
-    $version = $CLASS->$method("99 and 44/100 pure");
+    eval{$version = $CLASS->$method("99 and 44/100 pure")};
 
-    like($warning, qr/$warnregex/,
-       "Version string contains invalid data; ignoring");
-    is ("$version", "99", '$version eq "99"');
-    ok ($version->numify == 99.0, '$version->numify == 99.0');
-    ok ($version->normal eq "v99.0.0", '$version->normal eq v99.0.0');
+    like($@, qr/non-numeric data/,
+       "Invalid version format (non-numeric data)");
     
-    $version = $CLASS->$method("something");
-    like($warning, qr/$warnregex/,
-       "Version string contains invalid data; ignoring");
-    ok (defined $version, 'defined $version');
+    eval{$version = $CLASS->$method("something")};
+    like($@, qr/non-numeric data/,
+       "Invalid version format (non-numeric data)");
     
     # reset the test object to something reasonable
     $version = $CLASS->$method("1.2.3");
@@ -270,6 +328,11 @@ sub BaseTests {
     $new_version = $CLASS->$method("1.1.999");
     ok ( $version > $new_version, '$version > $new_version' );
     
+    diag "test with version class names" unless $ENV{PERL_CORE};
+    $version = $CLASS->$method("v1.2.3");
+    eval { () = $version < $CLASS };
+    like $@, qr/^Invalid version format/, "error with $version < $CLASS";
+    
     # that which is not expressly permitted is forbidden
     diag "forbidden operations" unless $ENV{PERL_CORE};
     ok ( !eval { ++$version }, "noop ++" );
@@ -295,7 +358,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");
@@ -416,20 +479,44 @@ SKIP: {
            'Replacement handles modules without VERSION'); 
        unlink $filename;
     }
+SKIP:    { # https://rt.perl.org/rt3/Ticket/Display.html?id=95544
+       skip "version require'd instead of use'd, cannot test UNIVERSAL::VERSION", 2
+           unless defined $qv_declare;
+       my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
+       (my $package = basename($filename)) =~ s/\.pm$//;
+       print $fh "package $package;\n\$VERSION = '3alpha';\n1;\n";
+       close $fh;
+       eval "use lib '.'; use $package; print $package->VERSION";
+       like ($@, qr/Invalid version format \(non-numeric data\)/,
+           'Warn about bad \$VERSION');
+       eval "use lib '.'; use $package 1;";
+       like ($@, qr/Invalid version format \(non-numeric data\)/,
+           'Warn about bad $VERSION');
+    }
 
 SKIP:  {
        skip 'Cannot test bare v-strings with Perl < 5.6.0', 4
                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};
@@ -556,10 +643,8 @@ SKIP: {
        my $warning;
        local $SIG{__WARN__} = sub { $warning = $_[0] };
 
-$DB::single = 1;
-       my $v = $CLASS->$method('1,7');
-       unlike($warning, qr"Version string '1,7' contains invalid data",
-           'Directly test comma as decimal compliance');
+       my $v = eval { $CLASS->$method('1,7') };
+#      is( $@, "", 'Directly test comma as decimal compliance');
 
        my $ver = 1.23;  # has to be floating point number
        my $orig_loc = setlocale( LC_ALL );
@@ -633,6 +718,70 @@ EOF
        my $badv2 = bless { qv => 1, version => [1,2,3] }, "version";
        is $badv2, 'v1.2.3', "Deal with badly serialized versions from YAML ";  
     }
+
+    {
+       # https://rt.cpan.org/Public/Bug/Display.html?id=70950
+       # test indirect usage of version objects
+       my $sum = 0;
+       eval '$sum += $CLASS->$method("v2.0.0")';
+       like $@, qr/operation not supported with version object/,
+           'No math operations with version objects';
+       # test direct usage of version objects
+       my $v = $CLASS->$method("v2.0.0");
+       eval '$v += 1';
+       like $@, qr/operation not supported with version object/,
+           'No math operations with version objects';
+    }
+
+    {
+       # https://rt.cpan.org/Ticket/Display.html?id=72365
+       # https://rt.perl.org/rt3/Ticket/Display.html?id=102586
+       eval 'my $v = $CLASS->$method("version")';
+       like $@, qr/Invalid version format/,
+           'The string "version" is not a version';
+       eval 'my $v = $CLASS->$method("ver510n")';
+       like $@, qr/Invalid version format/,
+           'All strings starting with "v" are not versions';
+    }
+
+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';
+    }
+
+    {
+       eval '$CLASS->$method("version")';
+       pass("no crash with ${CLASS}->${method}('version')");
+       {
+           package _102586;
+           sub TIESCALAR { bless [] }
+           sub FETCH { "version" }
+           sub STORE { }
+           my $v;
+           tie $v, __PACKAGE__;
+           $v = $CLASS->$method(1);
+           eval '$CLASS->$method($v)';
+       }
+       pass('no crash with version->new($tied) where $tied returns "version"');
+    }
 }
 
 1;