X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9b463b21d3655b79309f8b461042cebb5733c54e..e0b29447d8f7f6dc762b409db18ce496d6d6f46b:/lib/version.t

diff --git a/lib/version.t b/lib/version.t
index 7bce0eb..dd47e87 100644
--- a/lib/version.t
+++ b/lib/version.t
@@ -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/,
@@ -96,9 +92,15 @@ like($@, qr/Invalid version object/,
 eval { my $test = ($testobj > 1.0) };
 like($@, qr/Invalid version object/,
     "Bad subclass vcmp");
-strict_lax_tests();
+
+# 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
@@ -195,15 +197,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)");
     
@@ -211,6 +213,10 @@ sub BaseTests {
     like($@, qr/non-numeric data/,
 	"Invalid version format (non-numeric data)");
 
+    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
     {
     eval{$version = $CLASS->$method("99 and 44/100 pure")};
@@ -347,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");
@@ -468,20 +474,46 @@ 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; die $package->VERSION";
+	ok ($@ =~ /3alpha/, 'Even a bad $VERSION is returned');
+	eval "use lib '.'; use $package;";
+	unlike ($@, qr/Invalid version format \(non-numeric data\)/,
+	    'Do not warn about bad $VERSION unless asked');
+	eval "use lib '.'; use $package 1;";
+	like ($@, qr/Invalid version format \(non-numeric data\)/,
+	    'Warn about bad $VERSION when asked');
+    }
 
 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};
@@ -608,7 +640,6 @@ SKIP: {
 	my $warning;
 	local $SIG{__WARN__} = sub { $warning = $_[0] };
 
-$DB::single = 1;
 	my $v = eval { $CLASS->$method('1,7') };
 #	is( $@, "", 'Directly test comma as decimal compliance');
 
@@ -684,6 +715,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;