lib/version.t

   1 #! /usr/local/perl -w
   2
   3 use Test::More qw(no_plan);
   4 use Data::Dumper;
   5 require Test::Harness;
   6 no warnings 'once';
   7 *Verbose = \$Test::Harness::Verbose;
   8 use POSIX qw/locale_h/;
   9 use File::Temp qw/tempfile/;
  10 use File::Basename;
  11
  12 BEGIN {
  13     use_ok("version", 0.77);
  14     # If we made it this far, we are ok.
  15 }
  16
  17 my $Verbose;
  18
  19 diag "Tests with base class" unless $ENV{PERL_CORE};
  20
  21 BaseTests("version","new","qv");
  22 BaseTests("version","new","declare");
  23 BaseTests("version","parse", "qv");
  24 BaseTests("version","parse", "declare");
  25
  26 # dummy up a redundant call to satisfy David Wheeler
  27 local $SIG{__WARN__} = sub { die $_[0] };
  28 eval 'use version;';
  29 unlike ($@, qr/^Subroutine main::declare redefined/,
  30     "Only export declare once per package (to prevent redefined warnings).");
  31
  32 package version::Bad;
  33 use base 'version';
  34 sub new { my($self,$n)=@_;  bless \$n, $self }
  35
  36 package main;
  37
  38 my $warning;
  39 local $SIG{__WARN__} = sub { $warning = $_[0] };
  40 my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
  41 (my $package = basename($filename)) =~ s/\.pm$//;
  42 print $fh <<"EOF";
  43 # This is an empty subclass
  44 package $package;
  45 use base 'version';
  46 use vars '\$VERSION';
  47 \$VERSION=0.001;
  48 EOF
  49 close $fh;
  50
  51 sub main_reset {
  52     delete $main::INC{'$package'};
  53     undef &qv; undef *::qv; # avoid 'used once' warning
  54     undef &declare; undef *::declare; # avoid 'used once' warning
  55 }
  56
  57 diag "Tests with empty derived class"  unless $ENV{PERL_CORE};
  58
  59 use_ok($package, 0.001);
  60 my $testobj = $package->new(1.002_003);
  61 isa_ok( $testobj, $package );
  62 ok( $testobj->numify == 1.002003, "Numified correctly" );
  63 ok( $testobj->stringify eq "1.002003", "Stringified correctly" );
  64 ok( $testobj->normal eq "v1.2.3", "Normalified correctly" );
  65
  66 my $verobj = version::->new("1.2.4");
  67 ok( $verobj > $testobj, "Comparison vs parent class" );
  68
  69 BaseTests($package, "new", "qv");
  70 main_reset;
  71 use_ok($package, 0.001, "declare");
  72 BaseTests($package, "new", "declare");
  73 main_reset;
  74 use_ok($package, 0.001);
  75 BaseTests($package, "parse", "qv");
  76 main_reset;
  77 use_ok($package, 0.001, "declare");
  78 BaseTests($package, "parse", "declare");
  79
  80 diag "tests with bad subclass"  unless $ENV{PERL_CORE};
  81 $testobj = version::Bad->new(1.002_003);
  82 isa_ok( $testobj, "version::Bad" );
  83 eval { my $string = $testobj->numify };
  84 like($@, qr/Invalid version object/,
  85     "Bad subclass numify");
  86 eval { my $string = $testobj->normal };
  87 like($@, qr/Invalid version object/,
  88     "Bad subclass normal");
  89 eval { my $string = $testobj->stringify };
  90 like($@, qr/Invalid version object/,
  91     "Bad subclass stringify");
  92 eval { my $test = ($testobj > 1.0) };
  93 like($@, qr/Invalid version object/,
  94     "Bad subclass vcmp");
  95
  96 # Invalid structure
  97 eval { $a = \\version->new(1); bless $a, "version"; print "# $a\n" };
  98 like($@, qr/Invalid version object/,
  99     "Bad internal structure (RT#78286)");
 100
 101 # do strict lax tests in a sub to isolate a package to test importing
 102 strict_lax_tests();
 103
 104 sub strict_lax_tests {
 105   package temp12345;
 106   # copied from perl core test t/op/packagev.t
 107   # format: STRING STRICT_OK LAX_OK
 108   my $strict_lax_data = << 'CASE_DATA';
 109 1.00            pass    pass
 110 1.00001         pass    pass
 111 0.123           pass    pass
 112 12.345          pass    pass
 113 42              pass    pass
 114 0               pass    pass
 115 0.0             pass    pass
 116 v1.2.3          pass    pass
 117 v1.2.3.4        pass    pass
 118 v0.1.2          pass    pass
 119 v0.0.0          pass    pass
 120 01              fail    pass
 121 01.0203         fail    pass
 122 v01             fail    pass
 123 v01.02.03       fail    pass
 124 .1              fail    pass
 125 .1.2            fail    pass
 126 1.              fail    pass
 127 1.a             fail    fail
 128 1._             fail    fail
 129 1.02_03         fail    pass
 130 v1.2_3          fail    pass
 131 v1.02_03        fail    pass
 132 v1.2_3_4        fail    fail
 133 v1.2_3.4        fail    fail
 134 1.2_3.4         fail    fail
 135 0_              fail    fail
 136 1_              fail    fail
 137 1_.             fail    fail
 138 1.1_            fail    fail
 139 1.02_03_04      fail    fail
 140 1.2.3           fail    pass
 141 v1.2            fail    pass
 142 v0              fail    pass
 143 v1              fail    pass
 144 v.1.2.3         fail    fail
 145 v               fail    fail
 146 v1.2345.6       fail    pass
 147 undef           fail    pass
 148 1a              fail    fail
 149 1.2a3           fail    fail
 150 bar             fail    fail
 151 _               fail    fail
 152 CASE_DATA
 153
 154   require version;
 155   version->import( qw/is_strict is_lax/ );
 156   for my $case ( split qr/\n/, $strict_lax_data ) {
 157     my ($v, $strict, $lax) = split qr/\t+/, $case;
 158     main::ok( $strict eq 'pass' ? is_strict($v) : ! is_strict($v), "is_strict($v) [$strict]" );
 159     main::ok( $strict eq 'pass' ? version::is_strict($v) : ! version::is_strict($v), "version::is_strict($v) [$strict]" );
 160     main::ok( $lax eq 'pass' ? is_lax($v) : ! is_lax($v), "is_lax($v) [$lax]" );
 161     main::ok( $lax eq 'pass' ? version::is_lax($v) : ! version::is_lax($v), "version::is_lax($v) [$lax]" );
 162   }
 163 }
 164
 165 sub BaseTests {
 166
 167     my ($CLASS, $method, $qv_declare) = @_;
 168     my $warning;
 169     local $SIG{__WARN__} = sub { $warning = $_[0] };
 170
 171     # Insert your test code below, the Test module is use()ed here so read
 172     # its man page ( perldoc Test ) for help writing this test script.
 173
 174     # Test bare number processing
 175     diag "tests with bare numbers" unless $ENV{PERL_CORE};
 176     $version = $CLASS->$method(5.005_03);
 177     is ( "$version" , "5.00503" , '5.005_03 eq 5.00503' );
 178     $version = $CLASS->$method(1.23);
 179     is ( "$version" , "1.23" , '1.23 eq "1.23"' );
 180
 181     # Test quoted number processing
 182     diag "tests with quoted numbers" unless $ENV{PERL_CORE};
 183     $version = $CLASS->$method("5.005_03");
 184     is ( "$version" , "5.005_03" , '"5.005_03" eq "5.005_03"' );
 185     $version = $CLASS->$method("v1.23");
 186     is ( "$version" , "v1.23" , '"v1.23" eq "v1.23"' );
 187
 188     # Test stringify operator
 189     diag "tests with stringify" unless $ENV{PERL_CORE};
 190     $version = $CLASS->$method("5.005");
 191     is ( "$version" , "5.005" , '5.005 eq "5.005"' );
 192     $version = $CLASS->$method("5.006.001");
 193     is ( "$version" , "5.006.001" , '5.006.001 eq v5.6.1' );
 194     unlike ($warning, qr/v-string without leading 'v' deprecated/, 'No leading v');
 195     $version = $CLASS->$method("v1.2.3_4");
 196     is ( "$version" , "v1.2.3_4" , 'alpha version 1.2.3_4 eq v1.2.3_4' );
 197
 198     # test illegal formats
 199     diag "test illegal formats" unless $ENV{PERL_CORE};
 200     eval {my $version = $CLASS->$method("1.2_3_4")};
 201     like($@, qr/multiple underscores/,
 202         "Invalid version format (multiple underscores)");
 203
 204     eval {my $version = $CLASS->$method("1.2_3.4")};
 205     like($@, qr/underscores before decimal/,
 206         "Invalid version format (underscores before decimal)");
 207
 208     eval {my $version = $CLASS->$method("1_2")};
 209     like($@, qr/alpha without decimal/,
 210         "Invalid version format (alpha without decimal)");
 211
 212     eval { $version = $CLASS->$method("1.2b3")};
 213     like($@, qr/non-numeric data/,
 214         "Invalid version format (non-numeric data)");
 215
 216     eval { $version = $CLASS->$method("-1.23")};
 217     like($@, qr/negative version number/,
 218         "Invalid version format (negative version number)");
 219
 220     # from here on out capture the warning and test independently
 221     {
 222     eval{$version = $CLASS->$method("99 and 44/100 pure")};
 223
 224     like($@, qr/non-numeric data/,
 225         "Invalid version format (non-numeric data)");
 226
 227     eval{$version = $CLASS->$method("something")};
 228     like($@, qr/non-numeric data/,
 229         "Invalid version format (non-numeric data)");
 230
 231     # reset the test object to something reasonable
 232     $version = $CLASS->$method("1.2.3");
 233
 234     # Test boolean operator
 235     ok ($version, 'boolean');
 236
 237     # Test class membership
 238     isa_ok ( $version, $CLASS );
 239
 240     # Test comparison operators with self
 241     diag "tests with self" unless $ENV{PERL_CORE};
 242     is ( $version <=> $version, 0, '$version <=> $version == 0' );
 243     ok ( $version == $version, '$version == $version' );
 244
 245     # Test Numeric Comparison operators
 246     # test first with non-object
 247     $version = $CLASS->$method("5.006.001");
 248     $new_version = "5.8.0";
 249     diag "numeric tests with non-objects" unless $ENV{PERL_CORE};
 250     ok ( $version == $version, '$version == $version' );
 251     ok ( $version < $new_version, '$version < $new_version' );
 252     ok ( $new_version > $version, '$new_version > $version' );
 253     ok ( $version != $new_version, '$version != $new_version' );
 254
 255     # now test with existing object
 256     $new_version = $CLASS->$method($new_version);
 257     diag "numeric tests with objects" unless $ENV{PERL_CORE};
 258     ok ( $version < $new_version, '$version < $new_version' );
 259     ok ( $new_version > $version, '$new_version > $version' );
 260     ok ( $version != $new_version, '$version != $new_version' );
 261
 262     # now test with actual numbers
 263     diag "numeric tests with numbers" unless $ENV{PERL_CORE};
 264     ok ( $version->numify() == 5.006001, '$version->numify() == 5.006001' );
 265     ok ( $version->numify() <= 5.006001, '$version->numify() <= 5.006001' );
 266     ok ( $version->numify() < 5.008, '$version->numify() < 5.008' );
 267     #ok ( $version->numify() > v5.005_02, '$version->numify() > 5.005_02' );
 268
 269     # test with long decimals
 270     diag "Tests with extended decimal versions" unless $ENV{PERL_CORE};
 271     $version = $CLASS->$method(1.002003);
 272     ok ( $version == "1.2.3", '$version == "1.2.3"');
 273     ok ( $version->numify == 1.002003, '$version->numify == 1.002003');
 274     $version = $CLASS->$method("2002.09.30.1");
 275     ok ( $version == "2002.9.30.1",'$version == 2002.9.30.1');
 276     ok ( $version->numify == 2002.009030001,
 277         '$version->numify == 2002.009030001');
 278
 279     # now test with alpha version form with string
 280     $version = $CLASS->$method("1.2.3");
 281     $new_version = "1.2.3_4";
 282     diag "numeric tests with alpha-style non-objects" unless $ENV{PERL_CORE};
 283     ok ( $version < $new_version, '$version < $new_version' );
 284     ok ( $new_version > $version, '$new_version > $version' );
 285     ok ( $version != $new_version, '$version != $new_version' );
 286
 287     $version = $CLASS->$method("1.2.4");
 288     diag "numeric tests with alpha-style non-objects"
 289         unless $ENV{PERL_CORE};
 290     ok ( $version > $new_version, '$version > $new_version' );
 291     ok ( $new_version < $version, '$new_version < $version' );
 292     ok ( $version != $new_version, '$version != $new_version' );
 293
 294     # now test with alpha version form with object
 295     $version = $CLASS->$method("1.2.3");
 296     $new_version = $CLASS->$method("1.2.3_4");
 297     diag "tests with alpha-style objects" unless $ENV{PERL_CORE};
 298     ok ( $version < $new_version, '$version < $new_version' );
 299     ok ( $new_version > $version, '$new_version > $version' );
 300     ok ( $version != $new_version, '$version != $new_version' );
 301     ok ( !$version->is_alpha, '!$version->is_alpha');
 302     ok ( $new_version->is_alpha, '$new_version->is_alpha');
 303
 304     $version = $CLASS->$method("1.2.4");
 305     diag "tests with alpha-style objects" unless $ENV{PERL_CORE};
 306     ok ( $version > $new_version, '$version > $new_version' );
 307     ok ( $new_version < $version, '$new_version < $version' );
 308     ok ( $version != $new_version, '$version != $new_version' );
 309
 310     $version = $CLASS->$method("1.2.3.4");
 311     $new_version = $CLASS->$method("1.2.3_4");
 312     diag "tests with alpha-style objects with same subversion"
 313         unless $ENV{PERL_CORE};
 314     ok ( $version > $new_version, '$version > $new_version' );
 315     ok ( $new_version < $version, '$new_version < $version' );
 316     ok ( $version != $new_version, '$version != $new_version' );
 317
 318     diag "test implicit [in]equality" unless $ENV{PERL_CORE};
 319     $version = $CLASS->$method("v1.2.3");
 320     $new_version = $CLASS->$method("1.2.3.0");
 321     ok ( $version == $new_version, '$version == $new_version' );
 322     $new_version = $CLASS->$method("1.2.3_0");
 323     ok ( $version == $new_version, '$version == $new_version' );
 324     $new_version = $CLASS->$method("1.2.3.1");
 325     ok ( $version < $new_version, '$version < $new_version' );
 326     $new_version = $CLASS->$method("1.2.3_1");
 327     ok ( $version < $new_version, '$version < $new_version' );
 328     $new_version = $CLASS->$method("1.1.999");
 329     ok ( $version > $new_version, '$version > $new_version' );
 330
 331     # that which is not expressly permitted is forbidden
 332     diag "forbidden operations" unless $ENV{PERL_CORE};
 333     ok ( !eval { ++$version }, "noop ++" );
 334     ok ( !eval { --$version }, "noop --" );
 335     ok ( !eval { $version/1 }, "noop /" );
 336     ok ( !eval { $version*3 }, "noop *" );
 337     ok ( !eval { abs($version) }, "noop abs" );
 338
 339 SKIP: {
 340     skip "version require'd instead of use'd, cannot test $qv_declare", 3
 341         unless defined $qv_declare;
 342     # test the $qv_declare() sub
 343     diag "testing $qv_declare" unless $ENV{PERL_CORE};
 344     $version = $CLASS->$qv_declare("1.2");
 345     is ( "$version", "v1.2", $qv_declare.'("1.2") == "1.2.0"' );
 346     $version = $CLASS->$qv_declare(1.2);
 347     is ( "$version", "v1.2", $qv_declare.'(1.2) == "1.2.0"' );
 348     isa_ok( $CLASS->$qv_declare('5.008'), $CLASS );
 349 }
 350
 351     # test creation from existing version object
 352     diag "create new from existing version" unless $ENV{PERL_CORE};
 353     ok (eval {$new_version = $CLASS->$method($version)},
 354             "new from existing object");
 355     ok ($new_version == $version, "class->$method($version) identical");
 356     $new_version = $version->$method(0);
 357     isa_ok ($new_version, $CLASS );
 358     is ($new_version, "0", "version->$method() doesn't clone");
 359     $new_version = $version->$method("1.2.3");
 360     is ($new_version, "1.2.3" , '$version->$method("1.2.3") works too');
 361
 362     # test the CVS revision mode
 363     diag "testing CVS Revision" unless $ENV{PERL_CORE};
 364     $version = new $CLASS qw$Revision: 1.2$;
 365     ok ( $version == "1.2.0", 'qw$Revision: 1.2$ == 1.2.0' );
 366     $version = new $CLASS qw$Revision: 1.2.3.4$;
 367     ok ( $version == "1.2.3.4", 'qw$Revision: 1.2.3.4$ == 1.2.3.4' );
 368
 369     # test the CPAN style reduced significant digit form
 370     diag "testing CPAN-style versions" unless $ENV{PERL_CORE};
 371     $version = $CLASS->$method("1.23_01");
 372     is ( "$version" , "1.23_01", "CPAN-style alpha version" );
 373     ok ( $version > 1.23, "1.23_01 > 1.23");
 374     ok ( $version < 1.24, "1.23_01 < 1.24");
 375
 376     # test reformed UNIVERSAL::VERSION
 377     diag "Replacement UNIVERSAL::VERSION tests" unless $ENV{PERL_CORE};
 378
 379     my $error_regex = $] < 5.006
 380         ? 'version \d required'
 381         : 'does not define \$t.{7}::VERSION';
 382
 383     {
 384         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 385         (my $package = basename($filename)) =~ s/\.pm$//;
 386         print $fh "package $package;\n\$$package\::VERSION=0.58;\n1;\n";
 387         close $fh;
 388
 389         $version = 0.58;
 390         eval "use lib '.'; use $package $version";
 391         unlike($@, qr/$package version $version/,
 392                 'Replacement eval works with exact version');
 393
 394         # test as class method
 395         $new_version = $package->VERSION;
 396         cmp_ok($new_version,'==',$version, "Called as class method");
 397
 398         eval "print Completely::Unknown::Module->VERSION";
 399         if ( $] < 5.008 ) {
 400             unlike($@, qr/$error_regex/,
 401                 "Don't freak if the module doesn't even exist");
 402         }
 403         else {
 404             unlike($@, qr/defines neither package nor VERSION/,
 405                 "Don't freak if the module doesn't even exist");
 406         }
 407
 408         # this should fail even with old UNIVERSAL::VERSION
 409         $version += 0.01;
 410         eval "use lib '.'; use $package $version";
 411         like($@, qr/$package version $version/,
 412                 'Replacement eval works with incremented version');
 413
 414         $version =~ s/0+$//; #convert to string and remove trailing 0's
 415         chop($version); # shorten by 1 digit, should still succeed
 416         eval "use lib '.'; use $package $version";
 417         unlike($@, qr/$package version $version/,
 418                 'Replacement eval works with single digit');
 419
 420         # this would fail with old UNIVERSAL::VERSION
 421         $version += 0.1;
 422         eval "use lib '.'; use $package $version";
 423         like($@, qr/$package version $version/,
 424                 'Replacement eval works with incremented digit');
 425         unlink $filename;
 426     }
 427
 428     { # dummy up some variously broken modules for testing
 429         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 430         (my $package = basename($filename)) =~ s/\.pm$//;
 431         print $fh "1;\n";
 432         close $fh;
 433
 434         eval "use lib '.'; use $package 3;";
 435         if ( $] < 5.008 ) {
 436             like($@, qr/$error_regex/,
 437                 'Replacement handles modules without package or VERSION');
 438         }
 439         else {
 440             like($@, qr/defines neither package nor VERSION/,
 441                 'Replacement handles modules without package or VERSION');
 442         }
 443         eval "use lib '.'; use $package; \$version = $package->VERSION";
 444         unlike ($@, qr/$error_regex/,
 445             'Replacement handles modules without package or VERSION');
 446         ok (!defined($version), "Called as class method");
 447         unlink $filename;
 448     }
 449
 450     { # dummy up some variously broken modules for testing
 451         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 452         (my $package = basename($filename)) =~ s/\.pm$//;
 453         print $fh "package $package;\n#look ma no VERSION\n1;\n";
 454         close $fh;
 455         eval "use lib '.'; use $package 3;";
 456         like ($@, qr/$error_regex/,
 457             'Replacement handles modules without VERSION');
 458         eval "use lib '.'; use $package; print $package->VERSION";
 459         unlike ($@, qr/$error_regex/,
 460             'Replacement handles modules without VERSION');
 461         unlink $filename;
 462     }
 463
 464     { # dummy up some variously broken modules for testing
 465         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 466         (my $package = basename($filename)) =~ s/\.pm$//;
 467         print $fh "package $package;\n\@VERSION = ();\n1;\n";
 468         close $fh;
 469         eval "use lib '.'; use $package 3;";
 470         like ($@, qr/$error_regex/,
 471             'Replacement handles modules without VERSION');
 472         eval "use lib '.'; use $package; print $package->VERSION";
 473         unlike ($@, qr/$error_regex/,
 474             'Replacement handles modules without VERSION');
 475         unlink $filename;
 476     }
 477 SKIP:    { # https://rt.perl.org/rt3/Ticket/Display.html?id=95544
 478         skip "version require'd instead of use'd, cannot test UNIVERSAL::VERSION", 2
 479             unless defined $qv_declare;
 480         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 481         (my $package = basename($filename)) =~ s/\.pm$//;
 482         print $fh "package $package;\n\$VERSION = '3alpha';\n1;\n";
 483         close $fh;
 484         eval "use lib '.'; use $package; die $package->VERSION";
 485         ok ($@ =~ /3alpha/, 'Even a bad $VERSION is returned');
 486         eval "use lib '.'; use $package;";
 487         unlike ($@, qr/Invalid version format \(non-numeric data\)/,
 488             'Do not warn about bad $VERSION unless asked');
 489         eval "use lib '.'; use $package 1;";
 490         like ($@, qr/Invalid version format \(non-numeric data\)/,
 491             'Warn about bad $VERSION when asked');
 492     }
 493
 494 SKIP:   {
 495         skip 'Cannot test bare v-strings with Perl < 5.6.0', 4
 496                 if $] < 5.006_000;
 497         diag "Tests with v-strings" unless $ENV{PERL_CORE};
 498         $version = $CLASS->$method(1.2.3);
 499         ok("$version" eq "v1.2.3", '"$version" eq 1.2.3');
 500         $version = $CLASS->$method(1.0.0);
 501         $new_version = $CLASS->$method(1);
 502         ok($version == $new_version, '$version == $new_version');
 503         skip "version require'd instead of use'd, cannot test declare", 1
 504             unless defined $qv_declare;
 505         $version = &$qv_declare(1.2.3);
 506         ok("$version" eq "v1.2.3", 'v-string initialized $qv_declare()');
 507     }
 508
 509 SKIP:   {
 510         skip 'Cannot test bare alpha v-strings with Perl < 5.8.1', 2
 511                 if $] lt 5.008_001;
 512         diag "Tests with bare alpha v-strings" unless $ENV{PERL_CORE};
 513         $version = $CLASS->$method(v1.2.3_4);
 514         is($version, "v1.2.3_4", '"$version" eq "v1.2.3_4"');
 515         $version = $CLASS->$method(eval "v1.2.3_4");
 516         is($version, "v1.2.3_4", '"$version" eq "v1.2.3_4" (from eval)');
 517     }
 518
 519     diag "Tests with real-world (malformed) data" unless $ENV{PERL_CORE};
 520
 521     # trailing zero testing (reported by Andreas Koenig).
 522     $version = $CLASS->$method("1");
 523     ok($version->numify eq "1.000", "trailing zeros preserved");
 524     $version = $CLASS->$method("1.0");
 525     ok($version->numify eq "1.000", "trailing zeros preserved");
 526     $version = $CLASS->$method("1.0.0");
 527     ok($version->numify eq "1.000000", "trailing zeros preserved");
 528     $version = $CLASS->$method("1.0.0.0");
 529     ok($version->numify eq "1.000000000", "trailing zeros preserved");
 530
 531     # leading zero testing (reported by Andreas Koenig).
 532     $version = $CLASS->$method(".7");
 533     ok($version->numify eq "0.700", "leading zero inferred");
 534
 535     # leading space testing (reported by Andreas Koenig).
 536     $version = $CLASS->$method(" 1.7");
 537     ok($version->numify eq "1.700", "leading space ignored");
 538
 539     # RT 19517 - deal with undef and 'undef' initialization
 540     ok("$version" ne 'undef', "Undef version comparison #1");
 541     ok("$version" ne undef, "Undef version comparison #2");
 542     $version = $CLASS->$method('undef');
 543     unlike($warning, qr/^Version string 'undef' contains invalid data/,
 544         "Version string 'undef'");
 545
 546     $version = $CLASS->$method(undef);
 547     like($warning, qr/^Use of uninitialized value/,
 548         "Version string 'undef'");
 549     ok($version == 'undef', "Undef version comparison #3");
 550     ok($version ==  undef,  "Undef version comparison #4");
 551     eval "\$version = \$CLASS->$method()"; # no parameter at all
 552     unlike($@, qr/^Bizarre copy of CODE/, "No initializer at all");
 553     ok($version == 'undef', "Undef version comparison #5");
 554     ok($version ==  undef,  "Undef version comparison #6");
 555
 556     $version = $CLASS->$method(0.000001);
 557     unlike($warning, qr/^Version string '1e-06' contains invalid data/,
 558         "Very small version objects");
 559     }
 560
 561 SKIP: {
 562         my $warning;
 563         local $SIG{__WARN__} = sub { $warning = $_[0] };
 564         # dummy up a legal module for testing RT#19017
 565         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 566         (my $package = basename($filename)) =~ s/\.pm$//;
 567         print $fh <<"EOF";
 568 package $package;
 569 use $CLASS; \$VERSION = ${CLASS}->new('0.0.4');
 570 1;
 571 EOF
 572         close $fh;
 573
 574         eval "use lib '.'; use $package 0.000008;";
 575         like ($@, qr/^$package version 0.000008 required/,
 576             "Make sure very small versions don't freak");
 577         eval "use lib '.'; use $package 1;";
 578         like ($@, qr/^$package version 1 required/,
 579             "Comparing vs. version with no decimal");
 580         eval "use lib '.'; use $package 1.;";
 581         like ($@, qr/^$package version 1 required/,
 582             "Comparing vs. version with decimal only");
 583         if ( $] < 5.006_000 ) {
 584             skip 'Cannot "use" extended versions with Perl < 5.6.0', 3;
 585         }
 586         eval "use lib '.'; use $package v0.0.8;";
 587         my $regex = "^$package version v0.0.8 required";
 588         like ($@, qr/$regex/, "Make sure very small versions don't freak");
 589
 590         $regex =~ s/8/4/; # set for second test
 591         eval "use lib '.'; use $package v0.0.4;";
 592         unlike($@, qr/$regex/, 'Succeed - required == VERSION');
 593         cmp_ok ( $package->VERSION, 'eq', '0.0.4', 'No undef warnings' );
 594         unlink $filename;
 595     }
 596
 597 SKIP: {
 598     skip 'Cannot test "use base qw(version)"  when require is used', 3
 599         unless defined $qv_declare;
 600     my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 601     (my $package = basename($filename)) =~ s/\.pm$//;
 602     print $fh <<"EOF";
 603 package $package;
 604 use base qw(version);
 605 1;
 606 EOF
 607     close $fh;
 608     # need to eliminate any other $qv_declare()'s
 609     undef *{"main\::$qv_declare"};
 610     ok(!defined(&{"main\::$qv_declare"}), "make sure we cleared $qv_declare() properly");
 611     eval "use lib '.'; use $package qw/declare qv/;";
 612     ok(defined(&{"main\::$qv_declare"}), "make sure we exported $qv_declare() properly");
 613     isa_ok( &$qv_declare(1.2), $package);
 614     unlink $filename;
 615 }
 616
 617 SKIP: {
 618         if ( $] < 5.006_000 ) {
 619             skip 'Cannot "use" extended versions with Perl < 5.6.0', 3;
 620         }
 621         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 622         (my $package = basename($filename)) =~ s/\.pm$//;
 623         print $fh <<"EOF";
 624 package $package;
 625 \$VERSION = 1.0;
 626 1;
 627 EOF
 628         close $fh;
 629         eval "use lib '.'; use $package 1.001;";
 630         like ($@, qr/^$package version 1.001 required/,
 631             "User typed numeric so we error with numeric");
 632         eval "use lib '.'; use $package v1.1.0;";
 633         like ($@, qr/^$package version v1.1.0 required/,
 634             "User typed extended so we error with extended");
 635         unlink $filename;
 636     }
 637
 638 SKIP: {
 639         # test locale handling
 640         my $warning;
 641         local $SIG{__WARN__} = sub { $warning = $_[0] };
 642
 643         my $v = eval { $CLASS->$method('1,7') };
 644 #       is( $@, "", 'Directly test comma as decimal compliance');
 645
 646         my $ver = 1.23;  # has to be floating point number
 647         my $orig_loc = setlocale( LC_ALL );
 648         my $loc;
 649         while (<DATA>) {
 650             chomp;
 651             $loc = setlocale( LC_ALL, $_);
 652             last if localeconv()->{decimal_point} eq ',';
 653         }
 654         skip 'Cannot test locale handling without a comma locale', 4
 655             unless ( $loc and ($ver eq '1,23') );
 656
 657         diag ("Testing locale handling with $loc") unless $ENV{PERL_CORE};
 658
 659         $v = $CLASS->$method($ver);
 660         unlike($warning, qr/Version string '1,23' contains invalid data/,
 661             "Process locale-dependent floating point");
 662         is ($v, "1.23", "Locale doesn't apply to version objects");
 663         ok ($v == $ver, "Comparison to locale floating point");
 664
 665         setlocale( LC_ALL, $orig_loc); # reset this before possible skip
 666         skip 'Cannot test RT#46921 with Perl < 5.008', 1
 667             if ($] < 5.008);
 668         skip 'Cannot test RT#46921 with pure Perl module', 1
 669             if exists $INC{'version/vpp.pm'};
 670         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 671         (my $package = basename($filename)) =~ s/\.pm$//;
 672         print $fh <<"EOF";
 673 package $package;
 674 use POSIX qw(locale_h);
 675 \$^W = 1;
 676 use $CLASS;
 677 setlocale (LC_ALL, '$loc');
 678 use $CLASS ;
 679 eval "use Socket 1.7";
 680 setlocale( LC_ALL, '$orig_loc');
 681 1;
 682 EOF
 683         close $fh;
 684
 685         eval "use lib '.'; use $package;";
 686         unlike($warning, qr"Version string '1,7' contains invalid data",
 687             'Handle locale action-at-a-distance');
 688     }
 689
 690     eval 'my $v = $CLASS->$method("1._1");';
 691     unlike($@, qr/^Invalid version format \(alpha with zero width\)/,
 692         "Invalid version format 1._1");
 693
 694     {
 695         my $warning;
 696         local $SIG{__WARN__} = sub { $warning = $_[0] };
 697         eval 'my $v = $CLASS->$method(~0);';
 698         unlike($@, qr/Integer overflow in version/, "Too large version");
 699         like($warning, qr/Integer overflow in version/, "Too large version");
 700     }
 701
 702     {
 703         # http://rt.cpan.org/Public/Bug/Display.html?id=30004
 704         my $v1 = $CLASS->$method("v0.1_1");
 705         (my $alpha1 = Dumper($v1)) =~ s/.+'alpha' => ([^,]+),.+/$1/ms;
 706         my $v2 = $CLASS->$method($v1);
 707         (my $alpha2 = Dumper($v2)) =~ s/.+'alpha' => ([^,]+),.+/$1/ms;
 708         is $alpha2, $alpha1, "Don't fall for Data::Dumper's tricks";
 709     }
 710
 711     {
 712         # http://rt.perl.org/rt3/Ticket/Display.html?id=56606
 713         my $badv = bless { version => [1,2,3] }, "version";
 714         is $badv, '1.002003', "Deal with badly serialized versions from YAML";
 715         my $badv2 = bless { qv => 1, version => [1,2,3] }, "version";
 716         is $badv2, 'v1.2.3', "Deal with badly serialized versions from YAML ";
 717     }
 718 SKIP: {
 719         if ( $] < 5.006_000 ) {
 720             skip 'No v-string support at all < 5.6.0', 2;
 721         }
 722         # https://rt.cpan.org/Ticket/Display.html?id=49348
 723         my $v = $CLASS->$method("420");
 724         is "$v", "420", 'Correctly guesses this is not a v-string';
 725         $v = $CLASS->$method(4.2.0);
 726         is "$v", 'v4.2.0', 'Correctly guess that this is a v-string';
 727     }
 728 SKIP: {
 729         if ( $] < 5.006_000 ) {
 730             skip 'No v-string support at all < 5.6.0', 4;
 731         }
 732         # https://rt.cpan.org/Ticket/Display.html?id=50347
 733         # Check that the qv() implementation does not change
 734
 735         ok $CLASS->$method(1.2.3) < $CLASS->$method(1.2.3.1), 'Compare 3 and 4 digit v-strings' ;
 736         ok $CLASS->$method(v1.2.3) < $CLASS->$method(v1.2.3.1), 'Compare 3 and 4 digit v-strings, leaving v';
 737         ok $CLASS->$method("1.2.3") < $CLASS->$method("1.2.3.1"), 'Compare 3 and 4 digit v-strings, quoted';
 738         ok $CLASS->$method("v1.2.3") < $CLASS->$method("v1.2.3.1"), 'Compare 3 and 4 digit v-strings, quoted leading v';
 739     }
 740 }
 741
 742 1;
 743
 744 __DATA__
 745 af_ZA
 746 af_ZA.utf8
 747 an_ES
 748 an_ES.utf8
 749 az_AZ.utf8
 750 be_BY
 751 be_BY.utf8
 752 bg_BG
 753 bg_BG.utf8
 754 br_FR
 755 br_FR@euro
 756 br_FR.utf8
 757 bs_BA
 758 bs_BA.utf8
 759 ca_ES
 760 ca_ES@euro
 761 ca_ES.utf8
 762 cs_CZ
 763 cs_CZ.utf8
 764 da_DK
 765 da_DK.utf8
 766 de_AT
 767 de_AT@euro
 768 de_AT.utf8
 769 de_BE
 770 de_BE@euro
 771 de_BE.utf8
 772 de_DE
 773 de_DE@euro
 774 de_DE.utf8
 775 de_LU
 776 de_LU@euro
 777 de_LU.utf8
 778 el_GR
 779 el_GR.utf8
 780 en_DK
 781 en_DK.utf8
 782 es_AR
 783 es_AR.utf8
 784 es_BO
 785 es_BO.utf8
 786 es_CL
 787 es_CL.utf8
 788 es_CO
 789 es_CO.utf8
 790 es_EC
 791 es_EC.utf8
 792 es_ES
 793 es_ES@euro
 794 es_ES.utf8
 795 es_PY
 796 es_PY.utf8
 797 es_UY
 798 es_UY.utf8
 799 es_VE
 800 es_VE.utf8
 801 et_EE
 802 et_EE.iso885915
 803 et_EE.utf8
 804 eu_ES
 805 eu_ES@euro
 806 eu_ES.utf8
 807 fi_FI
 808 fi_FI@euro
 809 fi_FI.utf8
 810 fo_FO
 811 fo_FO.utf8
 812 fr_BE
 813 fr_BE@euro
 814 fr_BE.utf8
 815 fr_CA
 816 fr_CA.utf8
 817 fr_CH
 818 fr_CH.utf8
 819 fr_FR
 820 fr_FR@euro
 821 fr_FR.utf8
 822 fr_LU
 823 fr_LU@euro
 824 fr_LU.utf8
 825 gl_ES
 826 gl_ES@euro
 827 gl_ES.utf8
 828 hr_HR
 829 hr_HR.utf8
 830 hu_HU
 831 hu_HU.utf8
 832 id_ID
 833 id_ID.utf8
 834 is_IS
 835 is_IS.utf8
 836 it_CH
 837 it_CH.utf8
 838 it_IT
 839 it_IT@euro
 840 it_IT.utf8
 841 ka_GE
 842 ka_GE.utf8
 843 kk_KZ
 844 kk_KZ.utf8
 845 kl_GL
 846 kl_GL.utf8
 847 lt_LT
 848 lt_LT.utf8
 849 lv_LV
 850 lv_LV.utf8
 851 mk_MK
 852 mk_MK.utf8
 853 mn_MN
 854 mn_MN.utf8
 855 nb_NO
 856 nb_NO.utf8
 857 nl_BE
 858 nl_BE@euro
 859 nl_BE.utf8
 860 nl_NL
 861 nl_NL@euro
 862 nl_NL.utf8
 863 nn_NO
 864 nn_NO.utf8
 865 no_NO
 866 no_NO.utf8
 867 oc_FR
 868 oc_FR.utf8
 869 pl_PL
 870 pl_PL.utf8
 871 pt_BR
 872 pt_BR.utf8
 873 pt_PT
 874 pt_PT@euro
 875 pt_PT.utf8
 876 ro_RO
 877 ro_RO.utf8
 878 ru_RU
 879 ru_RU.koi8r
 880 ru_RU.utf8
 881 ru_UA
 882 ru_UA.utf8
 883 se_NO
 884 se_NO.utf8
 885 sh_YU
 886 sh_YU.utf8
 887 sk_SK
 888 sk_SK.utf8
 889 sl_SI
 890 sl_SI.utf8
 891 sq_AL
 892 sq_AL.utf8
 893 sr_CS
 894 sr_CS.utf8
 895 sv_FI
 896 sv_FI@euro
 897 sv_FI.utf8
 898 sv_SE
 899 sv_SE.iso885915
 900 sv_SE.utf8
 901 tg_TJ
 902 tg_TJ.utf8
 903 tr_TR
 904 tr_TR.utf8
 905 tt_RU.utf8
 906 uk_UA
 907 uk_UA.utf8
 908 vi_VN
 909 vi_VN.tcvn
 910 wa_BE
 911 wa_BE@euro
 912 wa_BE.utf8
 913