diff options
author | John Peacock <jpeacock@cpan.org> | 2011-12-12 12:57:11 -0500 |
---|---|---|
committer | David Golden <dagolden@cpan.org> | 2011-12-15 09:22:16 -0500 |
commit | 543eec9e1979e2f18230c426eaf530e04c6a86b6 (patch) | |
tree | 1ff9a250f8f0874a5464e2998e3c23414cf5da85 /lib | |
parent | 85ca3be751f142ad43c1dabcac68ab17a69c4c4d (diff) | |
download | perl-543eec9e1979e2f18230c426eaf530e04c6a86b6.tar.gz |
Merge CPAN version.pm tests into CORE.
It has become increasingly difficult to maintain the CPAN tests
and the CORE tests, so include the [subtly edited] CPAN tests
into the CORE code instead. NOTE: this also bumps $VERSION to
match the forthcoming CPAN release.
Signed-off-by: David Golden <dagolden@cpan.org>
Diffstat (limited to 'lib')
-rw-r--r-- | lib/version.pm | 2 | ||||
-rw-r--r-- | lib/version/t/01base.t | 34 | ||||
-rw-r--r-- | lib/version/t/02derived.t | 106 | ||||
-rw-r--r-- | lib/version/t/03require.t | 25 | ||||
-rw-r--r-- | lib/version/t/04strict_lax.t | 75 | ||||
-rw-r--r-- | lib/version/t/05sigdie.t | 21 | ||||
-rw-r--r-- | lib/version/t/06noop.t | 32 | ||||
-rw-r--r-- | lib/version/t/07locale.t | 236 | ||||
-rw-r--r-- | lib/version/t/coretests.pm (renamed from lib/version.t) | 507 |
9 files changed, 599 insertions, 439 deletions
diff --git a/lib/version.pm b/lib/version.pm index e5fd22e68d..65407e87db 100644 --- 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.93; +$VERSION = 0.96; $CLASS = 'version'; diff --git a/lib/version/t/01base.t b/lib/version/t/01base.t new file mode 100644 index 0000000000..f6d277ffd8 --- /dev/null +++ b/lib/version/t/01base.t @@ -0,0 +1,34 @@ +#! /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/; + +BEGIN { + (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm'; + require $coretests; + use_ok('version', 0.96); +} + +diag "Tests with base class" unless $ENV{PERL_CORE}; + +BaseTests("version","new","qv"); +BaseTests("version","new","declare"); +BaseTests("version","parse", "qv"); +BaseTests("version","parse", "declare"); + +# dummy up a redundant call to satify David Wheeler +local $SIG{__WARN__} = sub { die $_[0] }; +eval 'use version;'; +unlike ($@, qr/^Subroutine main::declare redefined/, + "Only export declare once per package (to prevent redefined warnings)."); + +# https://rt.cpan.org/Ticket/Display.html?id=47980 +my $v = eval { + require IO::Handle; + $@ = qq(Can't locate some/completely/fictitious/module.pm); + return IO::Handle->VERSION; +}; +ok defined($v), 'Fix for RT #47980'; diff --git a/lib/version/t/02derived.t b/lib/version/t/02derived.t new file mode 100644 index 0000000000..8ff4c17102 --- /dev/null +++ b/lib/version/t/02derived.t @@ -0,0 +1,106 @@ +#! /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 File::Temp qw/tempfile/; + +BEGIN { + (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm'; + require $coretests; + use_ok("version", 0.96); + # If we made it this far, we are ok. +} + +use lib qw/./; + +package version::Bad; +use base 'version'; +sub new { my($self,$n)=@_; bless \$n, $self } + +# Bad subclass for SemVer failures seen with pure Perl version.pm only +package version::Bad2; +use base 'version'; +sub new { + my ($class, $val) = @_; + die 'Invalid version string format' unless version::is_strict($val); + my $self = $class->SUPER::new($val); + return $self; +} +sub declare { + my ($class, $val) = @_; + my $self = $class->SUPER::declare($val); + return $self; +} + +package main; + +my $warning; +local $SIG{__WARN__} = sub { $warning = $_[0] }; +# dummy up a legal module for testing RT#19017 +my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); +(my $package = basename($filename)) =~ s/\.pm$//; +print $fh <<"EOF"; +# This is an empty subclass +package $package; +use base 'version'; +use vars '\$VERSION'; +\$VERSION=0.001; +EOF +close $fh; + +sub main_reset { + delete $main::INC{'$package'}; + undef &qv; undef *::qv; # avoid 'used once' warning + undef &declare; undef *::declare; # avoid 'used once' warning +} + +diag "Tests with empty derived class" unless $ENV{PERL_CORE}; + +use_ok($package, 0.001); +my $testobj = $package->new(1.002_003); +isa_ok( $testobj, $package ); +ok( $testobj->numify == 1.002003, "Numified correctly" ); +ok( $testobj->stringify eq "1.002003", "Stringified correctly" ); +ok( $testobj->normal eq "v1.2.3", "Normalified correctly" ); + +my $verobj = version::->new("1.2.4"); +ok( $verobj > $testobj, "Comparison vs parent class" ); + +BaseTests($package, "new", "qv"); +main_reset; +use_ok($package, 0.001, "declare"); +BaseTests($package, "new", "declare"); +main_reset; +use_ok($package, 0.001); +BaseTests($package, "parse", "qv"); +main_reset; +use_ok($package, 0.001, "declare"); +BaseTests($package, "parse", "declare"); + +diag "tests with bad subclass" unless $ENV{PERL_CORE}; +$testobj = version::Bad->new(1.002_003); +isa_ok( $testobj, "version::Bad" ); +eval { my $string = $testobj->numify }; +like($@, qr/Invalid version object/, + "Bad subclass numify"); +eval { my $string = $testobj->normal }; +like($@, qr/Invalid version object/, + "Bad subclass normal"); +eval { my $string = $testobj->stringify }; +like($@, qr/Invalid version object/, + "Bad subclass stringify"); +eval { my $test = ($testobj > 1.0) }; +like($@, qr/Invalid version object/, + "Bad subclass vcmp"); + +# Bad subclassing for SemVer with pure Perl version.pm only +eval { my $test = version::Bad2->new("01.1.2") }; +like($@, qr/Invalid version string format/, + "Correctly found invalid version"); + +eval { my $test = version::Bad2->declare("01.1.2") }; +unlike($@, qr/Invalid version string format/, + "Correctly ignored invalid version"); diff --git a/lib/version/t/03require.t b/lib/version/t/03require.t new file mode 100644 index 0000000000..b1376744f1 --- /dev/null +++ b/lib/version/t/03require.t @@ -0,0 +1,25 @@ +#! /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/; + +BEGIN { + (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm'; + require $coretests; +} + +# 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.96, "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" unless $ENV{PERL_CORE}; + +BaseTests("version","new",undef); +BaseTests("version","parse",undef); diff --git a/lib/version/t/04strict_lax.t b/lib/version/t/04strict_lax.t new file mode 100644 index 0000000000..24a7215409 --- /dev/null +++ b/lib/version/t/04strict_lax.t @@ -0,0 +1,75 @@ +#! /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/; + +# do strict lax tests in a sub to isolate a package to test importing +SKIP: { + skip 'No extended regexes Perl < 5.006', 172 + if $] < 5.006_000; + 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]" ); + } +} diff --git a/lib/version/t/05sigdie.t b/lib/version/t/05sigdie.t new file mode 100644 index 0000000000..190fc9002f --- /dev/null +++ b/lib/version/t/05sigdie.t @@ -0,0 +1,21 @@ +#! /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 => 1; + +BEGIN { + $SIG{__DIE__} = sub { + warn @_; + BAIL_OUT( q[Couldn't use module; can't continue.] ); + }; +} + + +BEGIN { + use version 0.96; +} + +pass "Didn't get caught by the wrong DIE handler, which is a good thing"; diff --git a/lib/version/t/06noop.t b/lib/version/t/06noop.t new file mode 100644 index 0000000000..c3915e4b33 --- /dev/null +++ b/lib/version/t/06noop.t @@ -0,0 +1,32 @@ +#! /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/; + +BEGIN { + use_ok('version', 0.96); +} + +my $v1 = version->new('1.2'); +eval {$v1 = $v1 + 1}; +like $@, qr/operation not supported with version object/, 'No math ops with version objects'; +eval {$v1 = $v1 - 1}; +like $@, qr/operation not supported with version object/, 'No math ops with version objects'; +eval {$v1 = $v1 / 1}; +like $@, qr/operation not supported with version object/, 'No math ops with version objects'; +eval {$v1 = $v1 * 1}; +like $@, qr/operation not supported with version object/, 'No math ops with version objects'; +eval {$v1 = abs($v1)}; +like $@, qr/operation not supported with version object/, 'No math ops with version objects'; + +eval {$v1 += 1}; +like $@, qr/operation not supported with version object/, 'No math ops with version objects'; +eval {$v1 -= 1}; +like $@, qr/operation not supported with version object/, 'No math ops with version objects'; +eval {$v1 /= 1}; +like $@, qr/operation not supported with version object/, 'No math ops with version objects'; +eval {$v1 *= 1}; +like $@, qr/operation not supported with version object/, 'No math ops with version objects'; diff --git a/lib/version/t/07locale.t b/lib/version/t/07locale.t new file mode 100644 index 0000000000..616eba4feb --- /dev/null +++ b/lib/version/t/07locale.t @@ -0,0 +1,236 @@ +#! /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 File::Basename; +use File::Temp qw/tempfile/; +use POSIX qw/locale_h/; +use Test::More qw/no_plan/; + +BEGIN { + use_ok('version', 0.96); +} + +SKIP: { + # test locale handling + my $warning; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + + my $v = eval { version->new('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 ); + my $loc; + while (<DATA>) { + chomp; + $loc = setlocale( LC_ALL, $_); + last if localeconv()->{decimal_point} eq ','; + } + skip 'Cannot test locale handling without a comma locale', 4 + unless ( $loc and ($ver eq '1,23') ); + + diag ("Testing locale handling with $loc") unless $ENV{PERL_CORE}; + + $v = version->new($ver); + unlike($warning, qr/Version string '1,23' contains invalid data/, + "Process locale-dependent floating point"); + is ($v, "1.23", "Locale doesn't apply to version objects"); + ok ($v == $ver, "Comparison to locale floating point"); + + setlocale( LC_ALL, $orig_loc); # reset this before possible skip + skip 'Cannot test RT#46921 with Perl < 5.008', 1 + if ($] < 5.008); + skip 'Cannot test RT#46921 with pure Perl module', 1 + if exists $INC{'version/vpp.pm'}; + my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); + (my $package = basename($filename)) =~ s/\.pm$//; + print $fh <<"EOF"; +package $package; +use POSIX qw(locale_h); +\$^W = 1; +use version; +setlocale (LC_ALL, '$loc'); +use version ; +eval "use Socket 1.7"; +setlocale( LC_ALL, '$orig_loc'); +1; +EOF + close $fh; + + eval "use lib '.'; use $package;"; + unlike($warning, qr"Version string '1,7' contains invalid data", + 'Handle locale action-at-a-distance'); + } + +__DATA__ +af_ZA +af_ZA.utf8 +an_ES +an_ES.utf8 +az_AZ.utf8 +be_BY +be_BY.utf8 +bg_BG +bg_BG.utf8 +br_FR +br_FR@euro +br_FR.utf8 +bs_BA +bs_BA.utf8 +ca_ES +ca_ES@euro +ca_ES.utf8 +cs_CZ +cs_CZ.utf8 +da_DK +da_DK.utf8 +de_AT +de_AT@euro +de_AT.utf8 +de_BE +de_BE@euro +de_BE.utf8 +de_DE +de_DE@euro +de_DE.utf8 +de_LU +de_LU@euro +de_LU.utf8 +el_GR +el_GR.utf8 +en_DK +en_DK.utf8 +es_AR +es_AR.utf8 +es_BO +es_BO.utf8 +es_CL +es_CL.utf8 +es_CO +es_CO.utf8 +es_EC +es_EC.utf8 +es_ES +es_ES@euro +es_ES.utf8 +es_PY +es_PY.utf8 +es_UY +es_UY.utf8 +es_VE +es_VE.utf8 +et_EE +et_EE.iso885915 +et_EE.utf8 +eu_ES +eu_ES@euro +eu_ES.utf8 +fi_FI +fi_FI@euro +fi_FI.utf8 +fo_FO +fo_FO.utf8 +fr_BE +fr_BE@euro +fr_BE.utf8 +fr_CA +fr_CA.utf8 +fr_CH +fr_CH.utf8 +fr_FR +fr_FR@euro +fr_FR.utf8 +fr_LU +fr_LU@euro +fr_LU.utf8 +gl_ES +gl_ES@euro +gl_ES.utf8 +hr_HR +hr_HR.utf8 +hu_HU +hu_HU.utf8 +id_ID +id_ID.utf8 +is_IS +is_IS.utf8 +it_CH +it_CH.utf8 +it_IT +it_IT@euro +it_IT.utf8 +ka_GE +ka_GE.utf8 +kk_KZ +kk_KZ.utf8 +kl_GL +kl_GL.utf8 +lt_LT +lt_LT.utf8 +lv_LV +lv_LV.utf8 +mk_MK +mk_MK.utf8 +mn_MN +mn_MN.utf8 +nb_NO +nb_NO.utf8 +nl_BE +nl_BE@euro +nl_BE.utf8 +nl_NL +nl_NL@euro +nl_NL.utf8 +nn_NO +nn_NO.utf8 +no_NO +no_NO.utf8 +oc_FR +oc_FR.utf8 +pl_PL +pl_PL.utf8 +pt_BR +pt_BR.utf8 +pt_PT +pt_PT@euro +pt_PT.utf8 +ro_RO +ro_RO.utf8 +ru_RU +ru_RU.koi8r +ru_RU.utf8 +ru_UA +ru_UA.utf8 +se_NO +se_NO.utf8 +sh_YU +sh_YU.utf8 +sk_SK +sk_SK.utf8 +sl_SI +sl_SI.utf8 +sq_AL +sq_AL.utf8 +sr_CS +sr_CS.utf8 +sv_FI +sv_FI@euro +sv_FI.utf8 +sv_SE +sv_SE.iso885915 +sv_SE.utf8 +tg_TJ +tg_TJ.utf8 +tr_TR +tr_TR.utf8 +tt_RU.utf8 +uk_UA +uk_UA.utf8 +vi_VN +vi_VN.tcvn +wa_BE +wa_BE@euro +wa_BE.utf8 diff --git a/lib/version.t b/lib/version/t/coretests.pm index 02846435a9..6d2b4c19fd 100644 --- a/lib/version.t +++ b/lib/version/t/coretests.pm @@ -1,165 +1,19 @@ #! /usr/local/perl -w - -use Test::More qw(no_plan); -use Data::Dumper; +package main; require Test::Harness; -no warnings 'once'; *Verbose = \$Test::Harness::Verbose; -use POSIX qw/locale_h/; +use Data::Dumper; use File::Temp qw/tempfile/; use File::Basename; -BEGIN { - use_ok("version", 0.77); - # If we made it this far, we are ok. -} - -my $Verbose; - -diag "Tests with base class" unless $ENV{PERL_CORE}; - -BaseTests("version","new","qv"); -BaseTests("version","new","declare"); -BaseTests("version","parse", "qv"); -BaseTests("version","parse", "declare"); - -# dummy up a redundant call to satisfy David Wheeler -local $SIG{__WARN__} = sub { die $_[0] }; -eval 'use version;'; -unlike ($@, qr/^Subroutine main::declare redefined/, - "Only export declare once per package (to prevent redefined warnings)."); - -package version::Bad; -use base 'version'; -sub new { my($self,$n)=@_; bless \$n, $self } - -package main; - -my $warning; -local $SIG{__WARN__} = sub { $warning = $_[0] }; -my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); -(my $package = basename($filename)) =~ s/\.pm$//; -print $fh <<"EOF"; -# This is an empty subclass -package $package; -use base 'version'; -use vars '\$VERSION'; -\$VERSION=0.001; -EOF -close $fh; - -sub main_reset { - delete $main::INC{'$package'}; - undef &qv; undef *::qv; # avoid 'used once' warning - undef &declare; undef *::declare; # avoid 'used once' warning -} - -diag "Tests with empty derived class" unless $ENV{PERL_CORE}; - -use_ok($package, 0.001); -my $testobj = $package->new(1.002_003); -isa_ok( $testobj, $package ); -ok( $testobj->numify == 1.002003, "Numified correctly" ); -ok( $testobj->stringify eq "1.002003", "Stringified correctly" ); -ok( $testobj->normal eq "v1.2.3", "Normalified correctly" ); - -my $verobj = version::->new("1.2.4"); -ok( $verobj > $testobj, "Comparison vs parent class" ); - -BaseTests($package, "new", "qv"); -main_reset; -use_ok($package, 0.001, "declare"); -BaseTests($package, "new", "declare"); -main_reset; -use_ok($package, 0.001); -BaseTests($package, "parse", "qv"); -main_reset; -use_ok($package, 0.001, "declare"); -BaseTests($package, "parse", "declare"); - -diag "tests with bad subclass" unless $ENV{PERL_CORE}; -$testobj = version::Bad->new(1.002_003); -isa_ok( $testobj, "version::Bad" ); -eval { my $string = $testobj->numify }; -like($@, qr/Invalid version object/, - "Bad subclass numify"); -eval { my $string = $testobj->normal }; -like($@, qr/Invalid version object/, - "Bad subclass normal"); -eval { my $string = $testobj->stringify }; -like($@, qr/Invalid version object/, - "Bad subclass stringify"); -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]" ); - } +if ($Test::More::VERSION < 0.48) { # Fix for RT#48268 + local $^W; + *main::use_ok = sub ($;@) { + my ($pkg, $req, @args) = @_; + eval "use $pkg $req ".join(' ',@args); + is ${"$pkg\::VERSION"}, $req, 'Had to manually use version'; + # If we made it this far, we are ok. + }; } sub BaseTests { @@ -167,24 +21,24 @@ sub BaseTests { my ($CLASS, $method, $qv_declare) = @_; my $warning; local $SIG{__WARN__} = sub { $warning = $_[0] }; - + # 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}; $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" unless $ENV{PERL_CORE}; $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" unless $ENV{PERL_CORE}; $version = $CLASS->$method("5.005"); @@ -194,21 +48,21 @@ sub BaseTests { unlike ($warning, qr/v-string without leading 'v' deprecated/, 'No leading v'); $version = $CLASS->$method("v1.2.3_4"); 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}; eval {my $version = $CLASS->$method("1.2_3_4")}; like($@, qr/multiple underscores/, "Invalid version format (multiple underscores)"); - + eval {my $version = $CLASS->$method("1.2_3.4")}; like($@, qr/underscores before decimal/, "Invalid version format (underscores before decimal)"); - + eval {my $version = $CLASS->$method("1_2")}; like($@, qr/alpha without decimal/, "Invalid version format (alpha without decimal)"); - + eval { $version = $CLASS->$method("1.2b3")}; like($@, qr/non-numeric data/, "Invalid version format (non-numeric data)"); @@ -223,25 +77,25 @@ sub BaseTests { like($@, qr/non-numeric data/, "Invalid version format (non-numeric data)"); - + 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"); - + # Test boolean operator ok ($version, 'boolean'); - + # Test class membership isa_ok ( $version, $CLASS ); - + # Test comparison operators with self diag "tests with self" unless $ENV{PERL_CORE}; is ( $version <=> $version, 0, '$version <=> $version == 0' ); ok ( $version == $version, '$version == $version' ); - + # Test Numeric Comparison operators # test first with non-object $version = $CLASS->$method("5.006.001"); @@ -251,21 +105,21 @@ sub BaseTests { ok ( $version < $new_version, '$version < $new_version' ); ok ( $new_version > $version, '$new_version > $version' ); ok ( $version != $new_version, '$version != $new_version' ); - + # now test with existing object $new_version = $CLASS->$method($new_version); diag "numeric tests with objects" unless $ENV{PERL_CORE}; 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}; 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}; $version = $CLASS->$method(1.002003); @@ -275,7 +129,7 @@ sub BaseTests { ok ( $version == "2002.9.30.1",'$version == 2002.9.30.1'); ok ( $version->numify == 2002.009030001, '$version->numify == 2002.009030001'); - + # now test with alpha version form with string $version = $CLASS->$method("1.2.3"); $new_version = "1.2.3_4"; @@ -283,14 +137,14 @@ sub BaseTests { 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" unless $ENV{PERL_CORE}; ok ( $version > $new_version, '$version > $new_version' ); ok ( $new_version < $version, '$new_version < $version' ); ok ( $version != $new_version, '$version != $new_version' ); - + # now test with alpha version form with object $version = $CLASS->$method("1.2.3"); $new_version = $CLASS->$method("1.2.3_4"); @@ -300,13 +154,13 @@ sub BaseTests { ok ( $version != $new_version, '$version != $new_version' ); ok ( !$version->is_alpha, '!$version->is_alpha'); ok ( $new_version->is_alpha, '$new_version->is_alpha'); - + $version = $CLASS->$method("1.2.4"); diag "tests with alpha-style objects" unless $ENV{PERL_CORE}; 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" @@ -314,7 +168,7 @@ sub BaseTests { 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}; $version = $CLASS->$method("v1.2.3"); $new_version = $CLASS->$method("1.2.3.0"); @@ -327,12 +181,12 @@ sub BaseTests { ok ( $version < $new_version, '$version < $new_version' ); $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"; - + eval { () = $version < 'version' }; + like $@, qr/^Invalid version format/, "error with $version < 'version'"; + # that which is not expressly permitted is forbidden diag "forbidden operations" unless $ENV{PERL_CORE}; ok ( !eval { ++$version }, "noop ++" ); @@ -343,7 +197,7 @@ sub BaseTests { SKIP: { skip "version require'd instead of use'd, cannot test $qv_declare", 3 - unless defined $qv_declare; + unless defined $qv_declare; # test the $qv_declare() sub diag "testing $qv_declare" unless $ENV{PERL_CORE}; $version = $CLASS->$qv_declare("1.2"); @@ -370,7 +224,7 @@ SKIP: { 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" unless $ENV{PERL_CORE}; $version = $CLASS->$method("1.23_01"); @@ -384,7 +238,7 @@ SKIP: { my $error_regex = $] < 5.006 ? 'version \d required' : 'does not define \$t.{7}::VERSION'; - + { my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); (my $package = basename($filename)) =~ s/\.pm$//; @@ -395,7 +249,7 @@ SKIP: { eval "use lib '.'; use $package $version"; unlike($@, qr/$package version $version/, 'Replacement eval works with exact version'); - + # test as class method $new_version = $package->VERSION; cmp_ok($new_version,'==',$version, "Called as class method"); @@ -415,13 +269,13 @@ SKIP: { eval "use lib '.'; use $package $version"; like($@, qr/$package version $version/, 'Replacement eval works with incremented version'); - + $version =~ s/0+$//; #convert to string and remove trailing 0's chop($version); # shorten by 1 digit, should still succeed eval "use lib '.'; use $package $version"; unlike($@, qr/$package version $version/, 'Replacement eval works with single digit'); - + # this would fail with old UNIVERSAL::VERSION $version += 0.1; eval "use lib '.'; use $package $version"; @@ -439,19 +293,19 @@ SKIP: { eval "use lib '.'; use $package 3;"; if ( $] < 5.008 ) { like($@, qr/$error_regex/, - 'Replacement handles modules without package or VERSION'); + 'Replacement handles modules without package or VERSION'); } else { like($@, qr/defines neither package nor VERSION/, - 'Replacement handles modules without package or VERSION'); + 'Replacement handles modules without package or VERSION'); } eval "use lib '.'; use $package; \$version = $package->VERSION"; unlike ($@, qr/$error_regex/, - 'Replacement handles modules without package or VERSION'); + 'Replacement handles modules without package or VERSION'); ok (!defined($version), "Called as class method"); unlink $filename; } - + { # dummy up some variously broken modules for testing my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); (my $package = basename($filename)) =~ s/\.pm$//; @@ -459,10 +313,10 @@ SKIP: { close $fh; eval "use lib '.'; use $package 3;"; like ($@, qr/$error_regex/, - 'Replacement handles modules without VERSION'); + 'Replacement handles modules without VERSION'); eval "use lib '.'; use $package; print $package->VERSION"; unlike ($@, qr/$error_regex/, - 'Replacement handles modules without VERSION'); + 'Replacement handles modules without VERSION'); unlink $filename; } @@ -473,10 +327,10 @@ SKIP: { close $fh; eval "use lib '.'; use $package 3;"; like ($@, qr/$error_regex/, - 'Replacement handles modules without VERSION'); + 'Replacement handles modules without VERSION'); eval "use lib '.'; use $package; print $package->VERSION"; unlike ($@, qr/$error_regex/, - 'Replacement handles modules without VERSION'); + 'Replacement handles modules without VERSION'); unlink $filename; } SKIP: { # https://rt.perl.org/rt3/Ticket/Display.html?id=95544 @@ -496,7 +350,7 @@ 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; + if $] < 5.006_000; diag "Tests with v-strings" unless $ENV{PERL_CORE}; $version = $CLASS->$method(1.2.3); ok("$version" eq "v1.2.3", '"$version" eq 1.2.3'); @@ -511,7 +365,7 @@ SKIP: { SKIP: { skip 'Cannot test bare alpha v-strings with Perl < 5.8.1', 2 - if $] lt 5.008_001; + 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"'); @@ -530,7 +384,7 @@ SKIP: { ok($version->numify eq "1.000000", "trailing zeros preserved"); $version = $CLASS->$method("1.0.0.0"); ok($version->numify eq "1.000000000", "trailing zeros preserved"); - + # leading zero testing (reported by Andreas Koenig). $version = $CLASS->$method(".7"); ok($version->numify eq "0.700", "leading zero inferred"); @@ -558,7 +412,7 @@ SKIP: { $version = $CLASS->$method(0.000001); unlike($warning, qr/^Version string '1e-06' contains invalid data/, - "Very small version objects"); + "Very small version objects"); } SKIP: { @@ -576,19 +430,19 @@ EOF eval "use lib '.'; use $package 0.000008;"; like ($@, qr/^$package version 0.000008 required/, - "Make sure very small versions don't freak"); + "Make sure very small versions don't freak"); eval "use lib '.'; use $package 1;"; like ($@, qr/^$package version 1 required/, - "Comparing vs. version with no decimal"); + "Comparing vs. version with no decimal"); eval "use lib '.'; use $package 1.;"; like ($@, qr/^$package version 1 required/, - "Comparing vs. version with decimal only"); + "Comparing vs. version with decimal only"); if ( $] < 5.006_000 ) { - skip 'Cannot "use" extended versions with Perl < 5.6.0', 3; + skip 'Cannot "use" extended versions with Perl < 5.6.0', 3; } eval "use lib '.'; use $package v0.0.8;"; my $regex = "^$package version v0.0.8 required"; - like ($@, qr/$regex/, "Make sure very small versions don't freak"); + like ($@, qr/$regex/, "Make sure very small versions don't freak"); $regex =~ s/8/4/; # set for second test eval "use lib '.'; use $package v0.0.4;"; @@ -599,7 +453,7 @@ EOF SKIP: { skip 'Cannot test "use base qw(version)" when require is used', 3 - unless defined $qv_declare; + unless defined $qv_declare; my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); (my $package = basename($filename)) =~ s/\.pm$//; print $fh <<"EOF"; @@ -619,7 +473,7 @@ EOF SKIP: { if ( $] < 5.006_000 ) { - skip 'Cannot "use" extended versions with Perl < 5.6.0', 3; + skip 'Cannot "use" extended versions with Perl < 5.6.0', 3; } my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); (my $package = basename($filename)) =~ s/\.pm$//; @@ -631,68 +485,16 @@ EOF close $fh; eval "use lib '.'; use $package 1.001;"; like ($@, qr/^$package version 1.001 required/, - "User typed numeric so we error with numeric"); + "User typed numeric so we error with numeric"); eval "use lib '.'; use $package v1.1.0;"; like ($@, qr/^$package version v1.1.0 required/, - "User typed extended so we error with extended"); + "User typed extended so we error with extended"); unlink $filename; } -SKIP: { - # test locale handling - my $warning; - local $SIG{__WARN__} = sub { $warning = $_[0] }; - - 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 ); - my $loc; - while (<DATA>) { - chomp; - $loc = setlocale( LC_ALL, $_); - last if localeconv()->{decimal_point} eq ','; - } - skip 'Cannot test locale handling without a comma locale', 4 - unless ( $loc and ($ver eq '1,23') ); - - diag ("Testing locale handling with $loc") unless $ENV{PERL_CORE}; - - $v = $CLASS->$method($ver); - unlike($warning, qr/Version string '1,23' contains invalid data/, - "Process locale-dependent floating point"); - is ($v, "1.23", "Locale doesn't apply to version objects"); - ok ($v == $ver, "Comparison to locale floating point"); - - setlocale( LC_ALL, $orig_loc); # reset this before possible skip - skip 'Cannot test RT#46921 with Perl < 5.008', 1 - if ($] < 5.008); - skip 'Cannot test RT#46921 with pure Perl module', 1 - if exists $INC{'version/vpp.pm'}; - my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); - (my $package = basename($filename)) =~ s/\.pm$//; - print $fh <<"EOF"; -package $package; -use POSIX qw(locale_h); -\$^W = 1; -use $CLASS; -setlocale (LC_ALL, '$loc'); -use $CLASS ; -eval "use Socket 1.7"; -setlocale( LC_ALL, '$orig_loc'); -1; -EOF - close $fh; - - eval "use lib '.'; use $package;"; - unlike($warning, qr"Version string '1,7' contains invalid data", - 'Handle locale action-at-a-distance'); - } - eval 'my $v = $CLASS->$method("1._1");'; unlike($@, qr/^Invalid version format \(alpha with zero width\)/, - "Invalid version format 1._1"); + "Invalid version format 1._1"); { my $warning; @@ -714,9 +516,9 @@ EOF { # http://rt.perl.org/rt3/Ticket/Display.html?id=56606 my $badv = bless { version => [1,2,3] }, "version"; - is $badv, '1.002003', "Deal with badly serialized versions from YAML"; + is $badv, '1.002003', "Deal with badly serialized versions from YAML"; my $badv2 = bless { qv => 1, version => [1,2,3] }, "version"; - is $badv2, 'v1.2.3', "Deal with badly serialized versions from YAML "; + is $badv2, 'v1.2.3', "Deal with badly serialized versions from YAML "; } { @@ -746,7 +548,7 @@ EOF SKIP: { if ( $] < 5.006_000 ) { - skip 'No v-string support at all < 5.6.0', 2; + 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"); @@ -756,7 +558,7 @@ SKIP: { } SKIP: { if ( $] < 5.006_000 ) { - skip 'No v-string support at all < 5.6.0', 4; + 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 @@ -785,174 +587,3 @@ SKIP: { } 1; - -__DATA__ -af_ZA -af_ZA.utf8 -an_ES -an_ES.utf8 -az_AZ.utf8 -be_BY -be_BY.utf8 -bg_BG -bg_BG.utf8 -br_FR -br_FR@euro -br_FR.utf8 -bs_BA -bs_BA.utf8 -ca_ES -ca_ES@euro -ca_ES.utf8 -cs_CZ -cs_CZ.utf8 -da_DK -da_DK.utf8 -de_AT -de_AT@euro -de_AT.utf8 -de_BE -de_BE@euro -de_BE.utf8 -de_DE -de_DE@euro -de_DE.utf8 -de_LU -de_LU@euro -de_LU.utf8 -el_GR -el_GR.utf8 -en_DK -en_DK.utf8 -es_AR -es_AR.utf8 -es_BO -es_BO.utf8 -es_CL -es_CL.utf8 -es_CO -es_CO.utf8 -es_EC -es_EC.utf8 -es_ES -es_ES@euro -es_ES.utf8 -es_PY -es_PY.utf8 -es_UY -es_UY.utf8 -es_VE -es_VE.utf8 -et_EE -et_EE.iso885915 -et_EE.utf8 -eu_ES -eu_ES@euro -eu_ES.utf8 -fi_FI -fi_FI@euro -fi_FI.utf8 -fo_FO -fo_FO.utf8 -fr_BE -fr_BE@euro -fr_BE.utf8 -fr_CA -fr_CA.utf8 -fr_CH -fr_CH.utf8 -fr_FR -fr_FR@euro -fr_FR.utf8 -fr_LU -fr_LU@euro -fr_LU.utf8 -gl_ES -gl_ES@euro -gl_ES.utf8 -hr_HR -hr_HR.utf8 -hu_HU -hu_HU.utf8 -id_ID -id_ID.utf8 -is_IS -is_IS.utf8 -it_CH -it_CH.utf8 -it_IT -it_IT@euro -it_IT.utf8 -ka_GE -ka_GE.utf8 -kk_KZ -kk_KZ.utf8 -kl_GL -kl_GL.utf8 -lt_LT -lt_LT.utf8 -lv_LV -lv_LV.utf8 -mk_MK -mk_MK.utf8 -mn_MN -mn_MN.utf8 -nb_NO -nb_NO.utf8 -nl_BE -nl_BE@euro -nl_BE.utf8 -nl_NL -nl_NL@euro -nl_NL.utf8 -nn_NO -nn_NO.utf8 -no_NO -no_NO.utf8 -oc_FR -oc_FR.utf8 -pl_PL -pl_PL.utf8 -pt_BR -pt_BR.utf8 -pt_PT -pt_PT@euro -pt_PT.utf8 -ro_RO -ro_RO.utf8 -ru_RU -ru_RU.koi8r -ru_RU.utf8 -ru_UA -ru_UA.utf8 -se_NO -se_NO.utf8 -sh_YU -sh_YU.utf8 -sk_SK -sk_SK.utf8 -sl_SI -sl_SI.utf8 -sq_AL -sq_AL.utf8 -sr_CS -sr_CS.utf8 -sv_FI -sv_FI@euro -sv_FI.utf8 -sv_SE -sv_SE.iso885915 -sv_SE.utf8 -tg_TJ -tg_TJ.utf8 -tr_TR -tr_TR.utf8 -tt_RU.utf8 -uk_UA -uk_UA.utf8 -vi_VN -vi_VN.tcvn -wa_BE -wa_BE@euro -wa_BE.utf8 - |