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     # from here on out capture the warning and test independently
 217     {
 218     eval{$version = $CLASS->$method("99 and 44/100 pure")};
 219
 220     like($@, qr/non-numeric data/,
 221         "Invalid version format (non-numeric data)");
 222
 223     eval{$version = $CLASS->$method("something")};
 224     like($@, qr/non-numeric data/,
 225         "Invalid version format (non-numeric data)");
 226
 227     # reset the test object to something reasonable
 228     $version = $CLASS->$method("1.2.3");
 229
 230     # Test boolean operator
 231     ok ($version, 'boolean');
 232
 233     # Test class membership
 234     isa_ok ( $version, $CLASS );
 235
 236     # Test comparison operators with self
 237     diag "tests with self" unless $ENV{PERL_CORE};
 238     is ( $version <=> $version, 0, '$version <=> $version == 0' );
 239     ok ( $version == $version, '$version == $version' );
 240
 241     # Test Numeric Comparison operators
 242     # test first with non-object
 243     $version = $CLASS->$method("5.006.001");
 244     $new_version = "5.8.0";
 245     diag "numeric tests with non-objects" unless $ENV{PERL_CORE};
 246     ok ( $version == $version, '$version == $version' );
 247     ok ( $version < $new_version, '$version < $new_version' );
 248     ok ( $new_version > $version, '$new_version > $version' );
 249     ok ( $version != $new_version, '$version != $new_version' );
 250
 251     # now test with existing object
 252     $new_version = $CLASS->$method($new_version);
 253     diag "numeric tests with objects" unless $ENV{PERL_CORE};
 254     ok ( $version < $new_version, '$version < $new_version' );
 255     ok ( $new_version > $version, '$new_version > $version' );
 256     ok ( $version != $new_version, '$version != $new_version' );
 257
 258     # now test with actual numbers
 259     diag "numeric tests with numbers" unless $ENV{PERL_CORE};
 260     ok ( $version->numify() == 5.006001, '$version->numify() == 5.006001' );
 261     ok ( $version->numify() <= 5.006001, '$version->numify() <= 5.006001' );
 262     ok ( $version->numify() < 5.008, '$version->numify() < 5.008' );
 263     #ok ( $version->numify() > v5.005_02, '$version->numify() > 5.005_02' );
 264
 265     # test with long decimals
 266     diag "Tests with extended decimal versions" unless $ENV{PERL_CORE};
 267     $version = $CLASS->$method(1.002003);
 268     ok ( $version == "1.2.3", '$version == "1.2.3"');
 269     ok ( $version->numify == 1.002003, '$version->numify == 1.002003');
 270     $version = $CLASS->$method("2002.09.30.1");
 271     ok ( $version == "2002.9.30.1",'$version == 2002.9.30.1');
 272     ok ( $version->numify == 2002.009030001,
 273         '$version->numify == 2002.009030001');
 274
 275     # now test with alpha version form with string
 276     $version = $CLASS->$method("1.2.3");
 277     $new_version = "1.2.3_4";
 278     diag "numeric tests with alpha-style non-objects" unless $ENV{PERL_CORE};
 279     ok ( $version < $new_version, '$version < $new_version' );
 280     ok ( $new_version > $version, '$new_version > $version' );
 281     ok ( $version != $new_version, '$version != $new_version' );
 282
 283     $version = $CLASS->$method("1.2.4");
 284     diag "numeric tests with alpha-style non-objects"
 285         unless $ENV{PERL_CORE};
 286     ok ( $version > $new_version, '$version > $new_version' );
 287     ok ( $new_version < $version, '$new_version < $version' );
 288     ok ( $version != $new_version, '$version != $new_version' );
 289
 290     # now test with alpha version form with object
 291     $version = $CLASS->$method("1.2.3");
 292     $new_version = $CLASS->$method("1.2.3_4");
 293     diag "tests with alpha-style objects" unless $ENV{PERL_CORE};
 294     ok ( $version < $new_version, '$version < $new_version' );
 295     ok ( $new_version > $version, '$new_version > $version' );
 296     ok ( $version != $new_version, '$version != $new_version' );
 297     ok ( !$version->is_alpha, '!$version->is_alpha');
 298     ok ( $new_version->is_alpha, '$new_version->is_alpha');
 299
 300     $version = $CLASS->$method("1.2.4");
 301     diag "tests with alpha-style objects" unless $ENV{PERL_CORE};
 302     ok ( $version > $new_version, '$version > $new_version' );
 303     ok ( $new_version < $version, '$new_version < $version' );
 304     ok ( $version != $new_version, '$version != $new_version' );
 305
 306     $version = $CLASS->$method("1.2.3.4");
 307     $new_version = $CLASS->$method("1.2.3_4");
 308     diag "tests with alpha-style objects with same subversion"
 309         unless $ENV{PERL_CORE};
 310     ok ( $version > $new_version, '$version > $new_version' );
 311     ok ( $new_version < $version, '$new_version < $version' );
 312     ok ( $version != $new_version, '$version != $new_version' );
 313
 314     diag "test implicit [in]equality" unless $ENV{PERL_CORE};
 315     $version = $CLASS->$method("v1.2.3");
 316     $new_version = $CLASS->$method("1.2.3.0");
 317     ok ( $version == $new_version, '$version == $new_version' );
 318     $new_version = $CLASS->$method("1.2.3_0");
 319     ok ( $version == $new_version, '$version == $new_version' );
 320     $new_version = $CLASS->$method("1.2.3.1");
 321     ok ( $version < $new_version, '$version < $new_version' );
 322     $new_version = $CLASS->$method("1.2.3_1");
 323     ok ( $version < $new_version, '$version < $new_version' );
 324     $new_version = $CLASS->$method("1.1.999");
 325     ok ( $version > $new_version, '$version > $new_version' );
 326
 327     # that which is not expressly permitted is forbidden
 328     diag "forbidden operations" unless $ENV{PERL_CORE};
 329     ok ( !eval { ++$version }, "noop ++" );
 330     ok ( !eval { --$version }, "noop --" );
 331     ok ( !eval { $version/1 }, "noop /" );
 332     ok ( !eval { $version*3 }, "noop *" );
 333     ok ( !eval { abs($version) }, "noop abs" );
 334
 335 SKIP: {
 336     skip "version require'd instead of use'd, cannot test $qv_declare", 3
 337         unless defined $qv_declare;
 338     # test the $qv_declare() sub
 339     diag "testing $qv_declare" unless $ENV{PERL_CORE};
 340     $version = $CLASS->$qv_declare("1.2");
 341     is ( "$version", "v1.2", $qv_declare.'("1.2") == "1.2.0"' );
 342     $version = $CLASS->$qv_declare(1.2);
 343     is ( "$version", "v1.2", $qv_declare.'(1.2) == "1.2.0"' );
 344     isa_ok( $CLASS->$qv_declare('5.008'), $CLASS );
 345 }
 346
 347     # test creation from existing version object
 348     diag "create new from existing version" unless $ENV{PERL_CORE};
 349     ok (eval {$new_version = $CLASS->$method($version)},
 350             "new from existing object");
 351     ok ($new_version == $version, "class->$method($version) identical");
 352     $new_version = $version->$method(0);
 353     isa_ok ($new_version, $CLASS );
 354     is ($new_version, "0", "version->$method() doesn't clone");
 355     $new_version = $version->$method("1.2.3");
 356     is ($new_version, "1.2.3" , '$version->$method("1.2.3") works too');
 357
 358     # test the CVS revision mode
 359     diag "testing CVS Revision" unless $ENV{PERL_CORE};
 360     $version = new $CLASS qw$Revision: 1.2$;
 361     ok ( $version == "1.2.0", 'qw$Revision: 1.2$ == 1.2.0' );
 362     $version = new $CLASS qw$Revision: 1.2.3.4$;
 363     ok ( $version == "1.2.3.4", 'qw$Revision: 1.2.3.4$ == 1.2.3.4' );
 364
 365     # test the CPAN style reduced significant digit form
 366     diag "testing CPAN-style versions" unless $ENV{PERL_CORE};
 367     $version = $CLASS->$method("1.23_01");
 368     is ( "$version" , "1.23_01", "CPAN-style alpha version" );
 369     ok ( $version > 1.23, "1.23_01 > 1.23");
 370     ok ( $version < 1.24, "1.23_01 < 1.24");
 371
 372     # test reformed UNIVERSAL::VERSION
 373     diag "Replacement UNIVERSAL::VERSION tests" unless $ENV{PERL_CORE};
 374
 375     my $error_regex = $] < 5.006
 376         ? 'version \d required'
 377         : 'does not define \$t.{7}::VERSION';
 378
 379     {
 380         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 381         (my $package = basename($filename)) =~ s/\.pm$//;
 382         print $fh "package $package;\n\$$package\::VERSION=0.58;\n1;\n";
 383         close $fh;
 384
 385         $version = 0.58;
 386         eval "use lib '.'; use $package $version";
 387         unlike($@, qr/$package version $version/,
 388                 'Replacement eval works with exact version');
 389
 390         # test as class method
 391         $new_version = $package->VERSION;
 392         cmp_ok($new_version,'==',$version, "Called as class method");
 393
 394         eval "print Completely::Unknown::Module->VERSION";
 395         if ( $] < 5.008 ) {
 396             unlike($@, qr/$error_regex/,
 397                 "Don't freak if the module doesn't even exist");
 398         }
 399         else {
 400             unlike($@, qr/defines neither package nor VERSION/,
 401                 "Don't freak if the module doesn't even exist");
 402         }
 403
 404         # this should fail even with old UNIVERSAL::VERSION
 405         $version += 0.01;
 406         eval "use lib '.'; use $package $version";
 407         like($@, qr/$package version $version/,
 408                 'Replacement eval works with incremented version');
 409
 410         $version =~ s/0+$//; #convert to string and remove trailing 0's
 411         chop($version); # shorten by 1 digit, should still succeed
 412         eval "use lib '.'; use $package $version";
 413         unlike($@, qr/$package version $version/,
 414                 'Replacement eval works with single digit');
 415
 416         # this would fail with old UNIVERSAL::VERSION
 417         $version += 0.1;
 418         eval "use lib '.'; use $package $version";
 419         like($@, qr/$package version $version/,
 420                 'Replacement eval works with incremented digit');
 421         unlink $filename;
 422     }
 423
 424     { # dummy up some variously broken modules for testing
 425         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 426         (my $package = basename($filename)) =~ s/\.pm$//;
 427         print $fh "1;\n";
 428         close $fh;
 429
 430         eval "use lib '.'; use $package 3;";
 431         if ( $] < 5.008 ) {
 432             like($@, qr/$error_regex/,
 433                 'Replacement handles modules without package or VERSION');
 434         }
 435         else {
 436             like($@, qr/defines neither package nor VERSION/,
 437                 'Replacement handles modules without package or VERSION');
 438         }
 439         eval "use lib '.'; use $package; \$version = $package->VERSION";
 440         unlike ($@, qr/$error_regex/,
 441             'Replacement handles modules without package or VERSION');
 442         ok (!defined($version), "Called as class method");
 443         unlink $filename;
 444     }
 445
 446     { # dummy up some variously broken modules for testing
 447         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 448         (my $package = basename($filename)) =~ s/\.pm$//;
 449         print $fh "package $package;\n#look ma no VERSION\n1;\n";
 450         close $fh;
 451         eval "use lib '.'; use $package 3;";
 452         like ($@, qr/$error_regex/,
 453             'Replacement handles modules without VERSION');
 454         eval "use lib '.'; use $package; print $package->VERSION";
 455         unlike ($@, qr/$error_regex/,
 456             'Replacement handles modules without VERSION');
 457         unlink $filename;
 458     }
 459
 460     { # dummy up some variously broken modules for testing
 461         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 462         (my $package = basename($filename)) =~ s/\.pm$//;
 463         print $fh "package $package;\n\@VERSION = ();\n1;\n";
 464         close $fh;
 465         eval "use lib '.'; use $package 3;";
 466         like ($@, qr/$error_regex/,
 467             'Replacement handles modules without VERSION');
 468         eval "use lib '.'; use $package; print $package->VERSION";
 469         unlike ($@, qr/$error_regex/,
 470             'Replacement handles modules without VERSION');
 471         unlink $filename;
 472     }
 473
 474 SKIP:   {
 475         skip 'Cannot test bare v-strings with Perl < 5.6.0', 4
 476                 if $] < 5.006_000;
 477         diag "Tests with v-strings" unless $ENV{PERL_CORE};
 478         $version = $CLASS->$method(1.2.3);
 479         ok("$version" eq "v1.2.3", '"$version" eq 1.2.3');
 480         $version = $CLASS->$method(1.0.0);
 481         $new_version = $CLASS->$method(1);
 482         ok($version == $new_version, '$version == $new_version');
 483         skip "version require'd instead of use'd, cannot test declare", 1
 484             unless defined $qv_declare;
 485         $version = &$qv_declare(1.2.3);
 486         ok("$version" eq "v1.2.3", 'v-string initialized $qv_declare()');
 487     }
 488
 489 SKIP:   {
 490         skip 'Cannot test bare alpha v-strings with Perl < 5.8.1', 2
 491                 if $] lt 5.008_001;
 492         diag "Tests with bare alpha v-strings" unless $ENV{PERL_CORE};
 493         $version = $CLASS->$method(v1.2.3_4);
 494         is($version, "v1.2.3_4", '"$version" eq "v1.2.3_4"');
 495         $version = $CLASS->$method(eval "v1.2.3_4");
 496         is($version, "v1.2.3_4", '"$version" eq "v1.2.3_4" (from eval)');
 497     }
 498
 499     diag "Tests with real-world (malformed) data" unless $ENV{PERL_CORE};
 500
 501     # trailing zero testing (reported by Andreas Koenig).
 502     $version = $CLASS->$method("1");
 503     ok($version->numify eq "1.000", "trailing zeros preserved");
 504     $version = $CLASS->$method("1.0");
 505     ok($version->numify eq "1.000", "trailing zeros preserved");
 506     $version = $CLASS->$method("1.0.0");
 507     ok($version->numify eq "1.000000", "trailing zeros preserved");
 508     $version = $CLASS->$method("1.0.0.0");
 509     ok($version->numify eq "1.000000000", "trailing zeros preserved");
 510
 511     # leading zero testing (reported by Andreas Koenig).
 512     $version = $CLASS->$method(".7");
 513     ok($version->numify eq "0.700", "leading zero inferred");
 514
 515     # leading space testing (reported by Andreas Koenig).
 516     $version = $CLASS->$method(" 1.7");
 517     ok($version->numify eq "1.700", "leading space ignored");
 518
 519     # RT 19517 - deal with undef and 'undef' initialization
 520     ok("$version" ne 'undef', "Undef version comparison #1");
 521     ok("$version" ne undef, "Undef version comparison #2");
 522     $version = $CLASS->$method('undef');
 523     unlike($warning, qr/^Version string 'undef' contains invalid data/,
 524         "Version string 'undef'");
 525
 526     $version = $CLASS->$method(undef);
 527     like($warning, qr/^Use of uninitialized value/,
 528         "Version string 'undef'");
 529     ok($version == 'undef', "Undef version comparison #3");
 530     ok($version ==  undef,  "Undef version comparison #4");
 531     eval "\$version = \$CLASS->$method()"; # no parameter at all
 532     unlike($@, qr/^Bizarre copy of CODE/, "No initializer at all");
 533     ok($version == 'undef', "Undef version comparison #5");
 534     ok($version ==  undef,  "Undef version comparison #6");
 535
 536     $version = $CLASS->$method(0.000001);
 537     unlike($warning, qr/^Version string '1e-06' contains invalid data/,
 538         "Very small version objects");
 539     }
 540
 541 SKIP: {
 542         my $warning;
 543         local $SIG{__WARN__} = sub { $warning = $_[0] };
 544         # dummy up a legal module for testing RT#19017
 545         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 546         (my $package = basename($filename)) =~ s/\.pm$//;
 547         print $fh <<"EOF";
 548 package $package;
 549 use $CLASS; \$VERSION = ${CLASS}->new('0.0.4');
 550 1;
 551 EOF
 552         close $fh;
 553
 554         eval "use lib '.'; use $package 0.000008;";
 555         like ($@, qr/^$package version 0.000008 required/,
 556             "Make sure very small versions don't freak");
 557         eval "use lib '.'; use $package 1;";
 558         like ($@, qr/^$package version 1 required/,
 559             "Comparing vs. version with no decimal");
 560         eval "use lib '.'; use $package 1.;";
 561         like ($@, qr/^$package version 1 required/,
 562             "Comparing vs. version with decimal only");
 563         if ( $] < 5.006_000 ) {
 564             skip 'Cannot "use" extended versions with Perl < 5.6.0', 3;
 565         }
 566         eval "use lib '.'; use $package v0.0.8;";
 567         my $regex = "^$package version v0.0.8 required";
 568         like ($@, qr/$regex/, "Make sure very small versions don't freak");
 569
 570         $regex =~ s/8/4/; # set for second test
 571         eval "use lib '.'; use $package v0.0.4;";
 572         unlike($@, qr/$regex/, 'Succeed - required == VERSION');
 573         cmp_ok ( $package->VERSION, 'eq', '0.0.4', 'No undef warnings' );
 574         unlink $filename;
 575     }
 576
 577 SKIP: {
 578     skip 'Cannot test "use base qw(version)"  when require is used', 3
 579         unless defined $qv_declare;
 580     my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 581     (my $package = basename($filename)) =~ s/\.pm$//;
 582     print $fh <<"EOF";
 583 package $package;
 584 use base qw(version);
 585 1;
 586 EOF
 587     close $fh;
 588     # need to eliminate any other $qv_declare()'s
 589     undef *{"main\::$qv_declare"};
 590     ok(!defined(&{"main\::$qv_declare"}), "make sure we cleared $qv_declare() properly");
 591     eval "use lib '.'; use $package qw/declare qv/;";
 592     ok(defined(&{"main\::$qv_declare"}), "make sure we exported $qv_declare() properly");
 593     isa_ok( &$qv_declare(1.2), $package);
 594     unlink $filename;
 595 }
 596
 597 SKIP: {
 598         if ( $] < 5.006_000 ) {
 599             skip 'Cannot "use" extended versions with Perl < 5.6.0', 3;
 600         }
 601         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 602         (my $package = basename($filename)) =~ s/\.pm$//;
 603         print $fh <<"EOF";
 604 package $package;
 605 \$VERSION = 1.0;
 606 1;
 607 EOF
 608         close $fh;
 609         eval "use lib '.'; use $package 1.001;";
 610         like ($@, qr/^$package version 1.001 required/,
 611             "User typed numeric so we error with numeric");
 612         eval "use lib '.'; use $package v1.1.0;";
 613         like ($@, qr/^$package version v1.1.0 required/,
 614             "User typed extended so we error with extended");
 615         unlink $filename;
 616     }
 617
 618 SKIP: {
 619         # test locale handling
 620         my $warning;
 621         local $SIG{__WARN__} = sub { $warning = $_[0] };
 622
 623 $DB::single = 1;
 624         my $v = eval { $CLASS->$method('1,7') };
 625 #       is( $@, "", 'Directly test comma as decimal compliance');
 626
 627         my $ver = 1.23;  # has to be floating point number
 628         my $orig_loc = setlocale( LC_ALL );
 629         my $loc;
 630         while (<DATA>) {
 631             chomp;
 632             $loc = setlocale( LC_ALL, $_);
 633             last if localeconv()->{decimal_point} eq ',';
 634         }
 635         skip 'Cannot test locale handling without a comma locale', 4
 636             unless ( $loc and ($ver eq '1,23') );
 637
 638         diag ("Testing locale handling with $loc") unless $ENV{PERL_CORE};
 639
 640         $v = $CLASS->$method($ver);
 641         unlike($warning, qr/Version string '1,23' contains invalid data/,
 642             "Process locale-dependent floating point");
 643         is ($v, "1.23", "Locale doesn't apply to version objects");
 644         ok ($v == $ver, "Comparison to locale floating point");
 645
 646         setlocale( LC_ALL, $orig_loc); # reset this before possible skip
 647         skip 'Cannot test RT#46921 with Perl < 5.008', 1
 648             if ($] < 5.008);
 649         skip 'Cannot test RT#46921 with pure Perl module', 1
 650             if exists $INC{'version/vpp.pm'};
 651         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 652         (my $package = basename($filename)) =~ s/\.pm$//;
 653         print $fh <<"EOF";
 654 package $package;
 655 use POSIX qw(locale_h);
 656 \$^W = 1;
 657 use $CLASS;
 658 setlocale (LC_ALL, '$loc');
 659 use $CLASS ;
 660 eval "use Socket 1.7";
 661 setlocale( LC_ALL, '$orig_loc');
 662 1;
 663 EOF
 664         close $fh;
 665
 666         eval "use lib '.'; use $package;";
 667         unlike($warning, qr"Version string '1,7' contains invalid data",
 668             'Handle locale action-at-a-distance');
 669     }
 670
 671     eval 'my $v = $CLASS->$method("1._1");';
 672     unlike($@, qr/^Invalid version format \(alpha with zero width\)/,
 673         "Invalid version format 1._1");
 674
 675     {
 676         my $warning;
 677         local $SIG{__WARN__} = sub { $warning = $_[0] };
 678         eval 'my $v = $CLASS->$method(~0);';
 679         unlike($@, qr/Integer overflow in version/, "Too large version");
 680         like($warning, qr/Integer overflow in version/, "Too large version");
 681     }
 682
 683     {
 684         # http://rt.cpan.org/Public/Bug/Display.html?id=30004
 685         my $v1 = $CLASS->$method("v0.1_1");
 686         (my $alpha1 = Dumper($v1)) =~ s/.+'alpha' => ([^,]+),.+/$1/ms;
 687         my $v2 = $CLASS->$method($v1);
 688         (my $alpha2 = Dumper($v2)) =~ s/.+'alpha' => ([^,]+),.+/$1/ms;
 689         is $alpha2, $alpha1, "Don't fall for Data::Dumper's tricks";
 690     }
 691
 692     {
 693         # http://rt.perl.org/rt3/Ticket/Display.html?id=56606
 694         my $badv = bless { version => [1,2,3] }, "version";
 695         is $badv, '1.002003', "Deal with badly serialized versions from YAML";
 696         my $badv2 = bless { qv => 1, version => [1,2,3] }, "version";
 697         is $badv2, 'v1.2.3', "Deal with badly serialized versions from YAML ";
 698     }
 699 SKIP: {
 700         if ( $] < 5.006_000 ) {
 701             skip 'No v-string support at all < 5.6.0', 2;
 702         }
 703         # https://rt.cpan.org/Ticket/Display.html?id=49348
 704         my $v = $CLASS->$method("420");
 705         is "$v", "420", 'Correctly guesses this is not a v-string';
 706         $v = $CLASS->$method(4.2.0);
 707         is "$v", 'v4.2.0', 'Correctly guess that this is a v-string';
 708     }
 709 SKIP: {
 710         if ( $] < 5.006_000 ) {
 711             skip 'No v-string support at all < 5.6.0', 4;
 712         }
 713         # https://rt.cpan.org/Ticket/Display.html?id=50347
 714         # Check that the qv() implementation does not change
 715
 716         ok $CLASS->$method(1.2.3) < $CLASS->$method(1.2.3.1), 'Compare 3 and 4 digit v-strings' ;
 717         ok $CLASS->$method(v1.2.3) < $CLASS->$method(v1.2.3.1), 'Compare 3 and 4 digit v-strings, leaving v';
 718         ok $CLASS->$method("1.2.3") < $CLASS->$method("1.2.3.1"), 'Compare 3 and 4 digit v-strings, quoted';
 719         ok $CLASS->$method("v1.2.3") < $CLASS->$method("v1.2.3.1"), 'Compare 3 and 4 digit v-strings, quoted leading v';
 720     }
 721 }
 722
 723 1;
 724
 725 __DATA__
 726 af_ZA
 727 af_ZA.utf8
 728 an_ES
 729 an_ES.utf8
 730 az_AZ.utf8
 731 be_BY
 732 be_BY.utf8
 733 bg_BG
 734 bg_BG.utf8
 735 br_FR
 736 br_FR@euro
 737 br_FR.utf8
 738 bs_BA
 739 bs_BA.utf8
 740 ca_ES
 741 ca_ES@euro
 742 ca_ES.utf8
 743 cs_CZ
 744 cs_CZ.utf8
 745 da_DK
 746 da_DK.utf8
 747 de_AT
 748 de_AT@euro
 749 de_AT.utf8
 750 de_BE
 751 de_BE@euro
 752 de_BE.utf8
 753 de_DE
 754 de_DE@euro
 755 de_DE.utf8
 756 de_LU
 757 de_LU@euro
 758 de_LU.utf8
 759 el_GR
 760 el_GR.utf8
 761 en_DK
 762 en_DK.utf8
 763 es_AR
 764 es_AR.utf8
 765 es_BO
 766 es_BO.utf8
 767 es_CL
 768 es_CL.utf8
 769 es_CO
 770 es_CO.utf8
 771 es_EC
 772 es_EC.utf8
 773 es_ES
 774 es_ES@euro
 775 es_ES.utf8
 776 es_PY
 777 es_PY.utf8
 778 es_UY
 779 es_UY.utf8
 780 es_VE
 781 es_VE.utf8
 782 et_EE
 783 et_EE.iso885915
 784 et_EE.utf8
 785 eu_ES
 786 eu_ES@euro
 787 eu_ES.utf8
 788 fi_FI
 789 fi_FI@euro
 790 fi_FI.utf8
 791 fo_FO
 792 fo_FO.utf8
 793 fr_BE
 794 fr_BE@euro
 795 fr_BE.utf8
 796 fr_CA
 797 fr_CA.utf8
 798 fr_CH
 799 fr_CH.utf8
 800 fr_FR
 801 fr_FR@euro
 802 fr_FR.utf8
 803 fr_LU
 804 fr_LU@euro
 805 fr_LU.utf8
 806 gl_ES
 807 gl_ES@euro
 808 gl_ES.utf8
 809 hr_HR
 810 hr_HR.utf8
 811 hu_HU
 812 hu_HU.utf8
 813 id_ID
 814 id_ID.utf8
 815 is_IS
 816 is_IS.utf8
 817 it_CH
 818 it_CH.utf8
 819 it_IT
 820 it_IT@euro
 821 it_IT.utf8
 822 ka_GE
 823 ka_GE.utf8
 824 kk_KZ
 825 kk_KZ.utf8
 826 kl_GL
 827 kl_GL.utf8
 828 lt_LT
 829 lt_LT.utf8
 830 lv_LV
 831 lv_LV.utf8
 832 mk_MK
 833 mk_MK.utf8
 834 mn_MN
 835 mn_MN.utf8
 836 nb_NO
 837 nb_NO.utf8
 838 nl_BE
 839 nl_BE@euro
 840 nl_BE.utf8
 841 nl_NL
 842 nl_NL@euro
 843 nl_NL.utf8
 844 nn_NO
 845 nn_NO.utf8
 846 no_NO
 847 no_NO.utf8
 848 oc_FR
 849 oc_FR.utf8
 850 pl_PL
 851 pl_PL.utf8
 852 pt_BR
 853 pt_BR.utf8
 854 pt_PT
 855 pt_PT@euro
 856 pt_PT.utf8
 857 ro_RO
 858 ro_RO.utf8
 859 ru_RU
 860 ru_RU.koi8r
 861 ru_RU.utf8
 862 ru_UA
 863 ru_UA.utf8
 864 se_NO
 865 se_NO.utf8
 866 sh_YU
 867 sh_YU.utf8
 868 sk_SK
 869 sk_SK.utf8
 870 sl_SI
 871 sl_SI.utf8
 872 sq_AL
 873 sq_AL.utf8
 874 sr_CS
 875 sr_CS.utf8
 876 sv_FI
 877 sv_FI@euro
 878 sv_FI.utf8
 879 sv_SE
 880 sv_SE.iso885915
 881 sv_SE.utf8
 882 tg_TJ
 883 tg_TJ.utf8
 884 tr_TR
 885 tr_TR.utf8
 886 tt_RU.utf8
 887 uk_UA
 888 uk_UA.utf8
 889 vi_VN
 890 vi_VN.tcvn
 891 wa_BE
 892 wa_BE@euro
 893 wa_BE.utf8
 894