Upgrade to version.pm 0.60

p4raw-id: //depot/perl@28276

1 files changed, 125 insertions, 31 deletions

diff --git a/lib/version.t b/lib/version.t
index 9ed5d5bde4..05c0965d51 100644
--- a/lib/version.t
+++ b/lib/version.t
@@ -5,6 +5,9 @@
 #########################
 
 use Test::More qw(no_plan);
+require Test::Harness;
+no warnings 'once';
+*Verbose = \$Test::Harness::Verbose;
 
 diag "Tests with base class" unless $ENV{PERL_CORE};
 
@@ -56,27 +59,27 @@ like($@, qr/Invalid version object/,
 
 sub BaseTests {
 
-	my $CLASS = shift;
+	my ($CLASS, $no_qv) = @_;
 	
 	# Insert your test code below, the Test module is use()ed here so read
 	# its man page ( perldoc Test ) for help writing this test script.
 	
 	# Test bare number processing
-	diag "tests with bare numbers" unless $ENV{PERL_CORE};
+	diag "tests with bare numbers" if $Verbose;
 	$version = $CLASS->new(5.005_03);
 	is ( "$version" , "5.005030" , '5.005_03 eq 5.5.30' );
 	$version = $CLASS->new(1.23);
 	is ( "$version" , "1.230" , '1.23 eq "1.230"' );
 	
 	# Test quoted number processing
-	diag "tests with quoted numbers" unless $ENV{PERL_CORE};
+	diag "tests with quoted numbers" if $Verbose;
 	$version = $CLASS->new("5.005_03");
 	is ( "$version" , "5.005_030" , '"5.005_03" eq "5.005_030"' );
 	$version = $CLASS->new("v1.23");
 	is ( "$version" , "v1.23.0" , '"v1.23" eq "v1.23.0"' );
 	
 	# Test stringify operator
-	diag "tests with stringify" unless $ENV{PERL_CORE};
+	diag "tests with stringify" if $Verbose;
 	$version = $CLASS->new("5.005");
 	is ( "$version" , "5.005" , '5.005 eq "5.005"' );
 	$version = $CLASS->new("5.006.001");
@@ -85,7 +88,7 @@ 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" unless $ENV{PERL_CORE};
+	diag "test illegal formats" if $Verbose;
 	eval {my $version = $CLASS->new("1.2_3_4")};
 	like($@, qr/multiple underscores/,
 	    "Invalid version format (multiple underscores)");
@@ -135,7 +138,7 @@ sub BaseTests {
 	isa_ok ( $version, $CLASS );
 	
 	# Test comparison operators with self
-	diag "tests with self" unless $ENV{PERL_CORE};
+	diag "tests with self" if $Verbose;
 	ok ( $version eq $version, '$version eq $version' );
 	is ( $version cmp $version, 0, '$version cmp $version == 0' );
 	ok ( $version == $version, '$version == $version' );
@@ -143,7 +146,7 @@ sub BaseTests {
 	# test first with non-object
 	$version = $CLASS->new("5.006.001");
 	$new_version = "5.8.0";
-	diag "tests with non-objects" unless $ENV{PERL_CORE};
+	diag "tests with non-objects" if $Verbose;
 	ok ( $version ne $new_version, '$version ne $new_version' );
 	ok ( $version lt $new_version, '$version lt $new_version' );
 	ok ( $new_version gt $version, '$new_version gt $version' );
@@ -154,7 +157,7 @@ sub BaseTests {
 	
 	# now test with existing object
 	$new_version = $CLASS->new("5.8.0");
-	diag "tests with objects" unless $ENV{PERL_CORE};
+	diag "tests with objects" if $Verbose;
 	ok ( $version ne $new_version, '$version ne $new_version' );
 	ok ( $version lt $new_version, '$version lt $new_version' );
 	ok ( $new_version gt $version, '$new_version gt $version' );
@@ -164,7 +167,7 @@ sub BaseTests {
 	# Test Numeric Comparison operators
 	# test first with non-object
 	$new_version = "5.8.0";
-	diag "numeric tests with non-objects" unless $ENV{PERL_CORE};
+	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' );
@@ -172,20 +175,20 @@ sub BaseTests {
 	
 	# now test with existing object
 	$new_version = $CLASS->new($new_version);
-	diag "numeric tests with objects" unless $ENV{PERL_CORE};
+	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" unless $ENV{PERL_CORE};
+	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" unless $ENV{PERL_CORE};
+	diag "Tests with extended decimal versions" if $Verbose;
 	$version = $CLASS->new(1.002003);
 	ok ( $version eq "1.2.3", '$version eq "1.2.3"');
 	ok ( $version->numify == 1.002003, '$version->numify == 1.002003');
@@ -197,13 +200,14 @@ sub BaseTests {
 	# now test with alpha version form with string
 	$version = $CLASS->new("1.2.3");
 	$new_version = "1.2.3_4";
-	diag "tests with alpha-style non-objects" unless $ENV{PERL_CORE};
+	diag "tests with alpha-style non-objects" if $Verbose;
 	ok ( $version lt $new_version, '$version lt $new_version' );
 	ok ( $new_version gt $version, '$new_version gt $version' );
 	ok ( $version ne $new_version, '$version ne $new_version' );
 	
 	$version = $CLASS->new("1.2.4");
-	diag "numeric tests with alpha-style non-objects" unless $ENV{PERL_CORE};
+	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' );
@@ -211,7 +215,7 @@ sub BaseTests {
 	# now test with alpha version form with object
 	$version = $CLASS->new("1.2.3");
 	$new_version = $CLASS->new("1.2.3_4");
-	diag "tests with alpha-style objects" unless $ENV{PERL_CORE};
+	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' );
@@ -219,19 +223,20 @@ sub BaseTests {
 	ok ( $new_version->is_alpha, '$new_version->is_alpha');
 	
 	$version = $CLASS->new("1.2.4");
-	diag "tests with alpha-style objects" unless $ENV{PERL_CORE};
+	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->new("1.2.3.4");
 	$new_version = $CLASS->new("1.2.3_4");
-	diag "tests with alpha-style objects with same subversion" unless $ENV{PERL_CORE};
+	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" unless $ENV{PERL_CORE};
+	diag "test implicit [in]equality" if $Verbose;
 	$version = $CLASS->new("v1.2.3");
 	$new_version = $CLASS->new("1.2.3.0");
 	ok ( $version == $new_version, '$version == $new_version' );
@@ -245,47 +250,52 @@ sub BaseTests {
 	ok ( $version > $new_version, '$version > $new_version' );
 	
 	# that which is not expressly permitted is forbidden
-	diag "forbidden operations" unless $ENV{PERL_CORE};
+	diag "forbidden operations" if $Verbose;
 	ok ( !eval { ++$version }, "noop ++" );
 	ok ( !eval { --$version }, "noop --" );
 	ok ( !eval { $version/1 }, "noop /" );
 	ok ( !eval { $version*3 }, "noop *" );
 	ok ( !eval { abs($version) }, "noop abs" );
 
+SKIP: {
+	skip "version require'd instead of use'd, cannot test qv", 3
+	    if defined $no_qv;
 	# test the qv() sub
-	diag "testing qv" unless $ENV{PERL_CORE};
+	diag "testing qv" if $Verbose;
 	$version = qv("1.2");
-	ok ( $version eq "1.2.0", 'qv("1.2") eq "1.2.0"' );
+	cmp_ok ( $version, "eq", "v1.2.0", 'qv("1.2") eq "1.2.0"' );
 	$version = qv(1.2);
-	ok ( $version eq "1.2.0", 'qv(1.2) eq "1.2.0"' );
+	cmp_ok ( $version, "eq", "v1.2.0", 'qv(1.2) eq "1.2.0"' );
 	isa_ok( qv('5.008'), $CLASS );
+}
 
 	# test creation from existing version object
-	diag "create new from existing version" unless $ENV{PERL_CORE};
+	diag "create new from existing version" if $Verbose;
 	ok (eval {$new_version = $CLASS->new($version)},
 		"new from existing object");
 	ok ($new_version == $version, "class->new($version) identical");
 	$new_version = $version->new();
-	ok ($new_version == $version, "$version->new() also identical");
+	isa_ok ($new_version, $CLASS );
+	is ($new_version, "0.000", "version->new() doesn't clone");
 	$new_version = $version->new("1.2.3");
 	is ($new_version, "v1.2.3" , '$version->new("1.2.3") works too');
 
 	# test the CVS revision mode
-	diag "testing CVS Revision" unless $ENV{PERL_CORE};
+	diag "testing CVS Revision" if $Verbose;
 	$version = new $CLASS qw$Revision: 1.2$;
 	ok ( $version eq "1.2.0", 'qw$Revision: 1.2$ eq 1.2.0' );
 	$version = new $CLASS qw$Revision: 1.2.3.4$;
 	ok ( $version eq "1.2.3.4", 'qw$Revision: 1.2.3.4$ eq 1.2.3.4' );
 	
 	# test the CPAN style reduced significant digit form
-	diag "testing CPAN-style versions" unless $ENV{PERL_CORE};
+	diag "testing CPAN-style versions" if $Verbose;
 	$version = $CLASS->new("1.23_01");
 	is ( "$version" , "1.23_0100", "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" unless $ENV{PERL_CORE};
+	diag "Replacement UNIVERSAL::VERSION tests" if $Verbose;
 	
 	# we know this file is here since we require it ourselves
 	$version = $Test::More::VERSION;
@@ -293,7 +303,12 @@ sub BaseTests {
 	unlike($@, qr/Test::More version $version/,
 		'Replacement eval works with exact version');
 	
-	$version = $Test::More::VERSION+0.01; # this should fail even with old UNIVERSAL::VERSION
+	# test as class method
+	$new_version = Test::More->VERSION;
+	cmp_ok($new_version,'cmp',$version, "Called as class method");
+
+	# this should fail even with old UNIVERSAL::VERSION
+	$version = $Test::More::VERSION+0.01;
 	eval "use Test::More $version";
 	like($@, qr/Test::More version $version/,
 		'Replacement eval works with incremented version');
@@ -309,21 +324,71 @@ sub BaseTests {
 	like($@, qr/Test::More version $version/,
 		'Replacement eval works with incremented digit');
 	
+	{ # dummy up some variously broken modules for testing
+	    open F, ">xxx.pm" or die "Cannot open xxx.pm: $!\n";
+	    print F "1;\n";
+	    close F;
+	    my $error_regex;
+	    if ( $] < 5.008 ) {
+		$error_regex = 'xxx does not define \$xxx::VERSION';
+	    }
+	    else {
+		$error_regex = 'xxx defines neither package nor VERSION';
+	    }
+
+	    eval "use lib '.'; use xxx 3;";
+	    like ($@, qr/$error_regex/,
+		'Replacement handles modules without package or VERSION'); 
+	    eval "use lib '.'; use xxx; $version = xxx->VERSION";
+	    unlike ($@, qr/$error_regex/,
+		'Replacement handles modules without package or VERSION'); 
+	    is ($versiona, undef, "Called as class method");
+	    unlink 'xxx.pm';
+	}
+    
+	{ # dummy up some variously broken modules for testing
+	    open F, ">yyy.pm" or die "Cannot open yyy.pm: $!\n";
+	    print F "package yyy;\n#look ma no VERSION\n1;\n";
+	    close F;
+	    eval "use lib '.'; use yyy 3;";
+	    like ($@, qr/^yyy does not define \$yyy::VERSION/,
+		'Replacement handles modules without VERSION'); 
+	    eval "use lib '.'; use yyy; print yyy->VERSION";
+	    unlike ($@, qr/^yyy does not define \$yyy::VERSION/,
+		'Replacement handles modules without VERSION'); 
+	    unlink 'yyy.pm';
+	}
+
+	{ # dummy up some variously broken modules for testing
+	    open F, ">zzz.pm" or die "Cannot open zzz.pm: $!\n";
+	    print F "package zzz;\n\@VERSION = ();\n1;\n";
+	    close F;
+	    eval "use lib '.'; use zzz 3;";
+	    like ($@, qr/^zzz does not define \$zzz::VERSION/,
+		'Replacement handles modules without VERSION'); 
+	    eval "use lib '.'; use zzz; print zzz->VERSION";
+	    unlike ($@, qr/^zzz does not define \$zzz::VERSION/,
+		'Replacement handles modules without VERSION'); 
+	    unlink 'zzz.pm';
+	}
+
 SKIP: 	{
-	    skip 'Cannot test v-strings with Perl < 5.8.1', 4
+	    skip 'Cannot test bare v-strings with Perl < 5.8.1', 4
 		    if $] < 5.008_001; 
-	    diag "Tests with v-strings" unless $ENV{PERL_CORE};
+	    diag "Tests with v-strings" if $Verbose;
 	    $version = $CLASS->new(1.2.3);
 	    ok("$version" eq "v1.2.3", '"$version" eq 1.2.3');
 	    $version = $CLASS->new(1.0.0);
 	    $new_version = $CLASS->new(1);
 	    ok($version == $new_version, '$version == $new_version');
 	    ok($version eq $new_version, '$version eq $new_version');
+	    skip "version require'd instead of use'd, cannot test qv", 1
+		if defined $no_qv;
 	    $version = qv(1.2.3);
 	    ok("$version" eq "v1.2.3", 'v-string initialized qv()');
 	}
 
-	diag "Tests with real-world (malformed) data" unless $ENV{PERL_CORE};
+	diag "Tests with real-world (malformed) data" if $Verbose;
 
 	# trailing zero testing (reported by Andreas Koenig).
 	$version = $CLASS->new("1");
@@ -343,6 +408,35 @@ SKIP: 	{
 	$version = $CLASS->new(" 1.7");
 	ok($version->numify eq "1.700", "leading space ignored");
 
+SKIP:	{
+
+	    # dummy up a legal module for testing RT#19017
+	    open F, ">www.pm" or die "Cannot open www.pm: $!\n";
+	    print F <<"EOF";
+package www;
+use version; \$VERSION = qv('0.0.4');
+1;
+EOF
+	    close F;
+
+	    eval "use lib '.'; use www 0.000008;";
+	    like ($@, qr/^www version 0.000008 \(v0.0.8\) 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/,
+		"Comparing vs. version with no decimal"); 
+	    eval "use lib '.'; use www 1.;";
+	    like ($@, qr/^www version 1.000 \(v1.0.0\) required/,
+		"Comparing "); 
+
+	    skip 'Cannot "use" extended versions with Perl < 5.6.2', 1
+		if $] < 5.006_002;
+	    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"); 
+
+	    unlink 'www.pm';
+	}
 }
 
 1;