lib/version.t

   1 #! /usr/local/perl -w
   2 # Before `make install' is performed this script should be runnable with
   3 # `make test'. After `make install' it should work as `perl test.pl'
   4
   5 #########################
   6
   7 use Test::More qw(no_plan);
   8 use Data::Dumper;
   9 require Test::Harness;
  10 no warnings 'once';
  11 *Verbose = \$Test::Harness::Verbose;
  12 use POSIX qw/locale_h/;
  13 use File::Temp qw/tempfile/;
  14 use File::Basename;
  15
  16 BEGIN {
  17     use_ok("version", 0.77);
  18     # If we made it this far, we are ok.
  19 }
  20
  21 my $Verbose;
  22
  23 diag "Tests with base class" unless $ENV{PERL_CORE};
  24
  25 BaseTests("version","new","qv");
  26 BaseTests("version","new","declare");
  27 BaseTests("version","parse", "qv");
  28 BaseTests("version","parse", "declare");
  29
  30 # dummy up a redundant call to satify David Wheeler
  31 local $SIG{__WARN__} = sub { die $_[0] };
  32 eval 'use version;';
  33 unlike ($@, qr/^Subroutine main::declare redefined/,
  34     "Only export declare once per package (to prevent redefined warnings).");
  35
  36 package version::Bad;
  37 use base 'version';
  38 sub new { my($self,$n)=@_;  bless \$n, $self }
  39
  40 package main;
  41
  42 my $warning;
  43 local $SIG{__WARN__} = sub { $warning = $_[0] };
  44 my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
  45 (my $package = basename($filename)) =~ s/\.pm$//;
  46 print $fh <<"EOF";
  47 # This is an empty subclass
  48 package $package;
  49 use base 'version';
  50 use vars '\$VERSION';
  51 \$VERSION=0.001;
  52 EOF
  53 close $fh;
  54
  55 sub main_reset {
  56     delete $main::INC{'$package'};
  57     undef &qv; undef *::qv; # avoid 'used once' warning
  58     undef &declare; undef *::declare; # avoid 'used once' warning
  59 }
  60
  61 diag "Tests with empty derived class"  unless $ENV{PERL_CORE};
  62
  63 use_ok($package, 0.001);
  64 my $testobj = $package->new(1.002_003);
  65 isa_ok( $testobj, $package );
  66 ok( $testobj->numify == 1.002003, "Numified correctly" );
  67 ok( $testobj->stringify eq "1.002003", "Stringified correctly" );
  68 ok( $testobj->normal eq "v1.2.3", "Normalified correctly" );
  69
  70 my $verobj = version::->new("1.2.4");
  71 ok( $verobj > $testobj, "Comparison vs parent class" );
  72
  73 BaseTests($package, "new", "qv");
  74 main_reset;
  75 use_ok($package, 0.001, "declare");
  76 BaseTests($package, "new", "declare");
  77 main_reset;
  78 use_ok($package, 0.001);
  79 BaseTests($package, "parse", "qv");
  80 main_reset;
  81 use_ok($package, 0.001, "declare");
  82 BaseTests($package, "parse", "declare");
  83
  84 diag "tests with bad subclass"  unless $ENV{PERL_CORE};
  85 $testobj = version::Bad->new(1.002_003);
  86 isa_ok( $testobj, "version::Bad" );
  87 eval { my $string = $testobj->numify };
  88 like($@, qr/Invalid version object/,
  89     "Bad subclass numify");
  90 eval { my $string = $testobj->normal };
  91 like($@, qr/Invalid version object/,
  92     "Bad subclass normal");
  93 eval { my $string = $testobj->stringify };
  94 like($@, qr/Invalid version object/,
  95     "Bad subclass stringify");
  96 eval { my $test = ($testobj > 1.0) };
  97 like($@, qr/Invalid version object/,
  98     "Bad subclass vcmp");
  99
 100 # Invalid structure
 101 eval { $a = \\version->new(1); bless $a, "version"; print "# $a\n" };
 102 like($@, qr/Invalid version object/,
 103     "Bad internal structure (RT#78286)");
 104
 105 # do strict lax tests in a sub to isolate a package to test importing
 106 strict_lax_tests();
 107
 108 sub strict_lax_tests {
 109   package temp12345;
 110   # copied from perl core test t/op/packagev.t
 111   # format: STRING STRICT_OK LAX_OK
 112   my $strict_lax_data = << 'CASE_DATA';
 113 1.00            pass    pass
 114 1.00001         pass    pass
 115 0.123           pass    pass
 116 12.345          pass    pass
 117 42              pass    pass
 118 0               pass    pass
 119 0.0             pass    pass
 120 v1.2.3          pass    pass
 121 v1.2.3.4        pass    pass
 122 v0.1.2          pass    pass
 123 v0.0.0          pass    pass
 124 01              fail    pass
 125 01.0203         fail    pass
 126 v01             fail    pass
 127 v01.02.03       fail    pass
 128 .1              fail    pass
 129 .1.2            fail    pass
 130 1.              fail    pass
 131 1.a             fail    fail
 132 1._             fail    fail
 133 1.02_03         fail    pass
 134 v1.2_3          fail    pass
 135 v1.02_03        fail    pass
 136 v1.2_3_4        fail    fail
 137 v1.2_3.4        fail    fail
 138 1.2_3.4         fail    fail
 139 0_              fail    fail
 140 1_              fail    fail
 141 1_.             fail    fail
 142 1.1_            fail    fail
 143 1.02_03_04      fail    fail
 144 1.2.3           fail    pass
 145 v1.2            fail    pass
 146 v0              fail    pass
 147 v1              fail    pass
 148 v.1.2.3         fail    fail
 149 v               fail    fail
 150 v1.2345.6       fail    pass
 151 undef           fail    pass
 152 1a              fail    fail
 153 1.2a3           fail    fail
 154 bar             fail    fail
 155 _               fail    fail
 156 CASE_DATA
 157
 158   require version;
 159   version->import( qw/is_strict is_lax/ );
 160   for my $case ( split qr/\n/, $strict_lax_data ) {
 161     my ($v, $strict, $lax) = split qr/\t+/, $case;
 162     main::ok( $strict eq 'pass' ? is_strict($v) : ! is_strict($v), "is_strict($v) [$strict]" );
 163     main::ok( $strict eq 'pass' ? version::is_strict($v) : ! version::is_strict($v), "version::is_strict($v) [$strict]" );
 164     main::ok( $lax eq 'pass' ? is_lax($v) : ! is_lax($v), "is_lax($v) [$lax]" );
 165     main::ok( $lax eq 'pass' ? version::is_lax($v) : ! version::is_lax($v), "version::is_lax($v) [$lax]" );
 166   }
 167 }
 168
 169 sub BaseTests {
 170
 171     my ($CLASS, $method, $qv_declare) = @_;
 172     my $warning;
 173     local $SIG{__WARN__} = sub { $warning = $_[0] };
 174
 175     # Insert your test code below, the Test module is use()ed here so read
 176     # its man page ( perldoc Test ) for help writing this test script.
 177
 178     # Test bare number processing
 179     diag "tests with bare numbers" unless $ENV{PERL_CORE};
 180     $version = $CLASS->$method(5.005_03);
 181     is ( "$version" , "5.00503" , '5.005_03 eq 5.00503' );
 182     $version = $CLASS->$method(1.23);
 183     is ( "$version" , "1.23" , '1.23 eq "1.23"' );
 184
 185     # Test quoted number processing
 186     diag "tests with quoted numbers" unless $ENV{PERL_CORE};
 187     $version = $CLASS->$method("5.005_03");
 188     is ( "$version" , "5.005_03" , '"5.005_03" eq "5.005_03"' );
 189     $version = $CLASS->$method("v1.23");
 190     is ( "$version" , "v1.23" , '"v1.23" eq "v1.23"' );
 191
 192     # Test stringify operator
 193     diag "tests with stringify" unless $ENV{PERL_CORE};
 194     $version = $CLASS->$method("5.005");
 195     is ( "$version" , "5.005" , '5.005 eq "5.005"' );
 196     $version = $CLASS->$method("5.006.001");
 197     is ( "$version" , "5.006.001" , '5.006.001 eq v5.6.1' );
 198     unlike ($warning, qr/v-string without leading 'v' deprecated/, 'No leading v');
 199     $version = $CLASS->$method("v1.2.3_4");
 200     is ( "$version" , "v1.2.3_4" , 'alpha version 1.2.3_4 eq v1.2.3_4' );
 201
 202     # test illegal formats
 203     diag "test illegal formats" unless $ENV{PERL_CORE};
 204     eval {$version = $CLASS->$method("1.2_3_4")};
 205     like($@, qr/multiple underscores/,
 206         "Invalid version format (multiple underscores)");
 207
 208     eval {$version = $CLASS->$method("1.2_3.4")};
 209     like($@, qr/underscores before decimal/,
 210         "Invalid version format (underscores before decimal)");
 211
 212     eval {$version = $CLASS->$method("1_2")};
 213     like($@, qr/alpha without decimal/,
 214         "Invalid version format (alpha without decimal)");
 215
 216     eval { $version = $CLASS->$method("1.2b3")};
 217     like($@, qr/non-numeric data/,
 218         "Invalid version format (non-numeric data)");
 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();
 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
 478 SKIP:   {
 479         skip 'Cannot test bare v-strings with Perl < 5.6.0', 4
 480                 if $] < 5.006_000;
 481         diag "Tests with v-strings" unless $ENV{PERL_CORE};
 482         $version = $CLASS->$method(1.2.3);
 483         ok("$version" == "v1.2.3", '"$version" == 1.2.3');
 484         $version = $CLASS->$method(1.0.0);
 485         $new_version = $CLASS->$method(1);
 486         ok($version == $new_version, '$version == $new_version');
 487         skip "version require'd instead of use'd, cannot test declare", 1
 488             unless defined $qv_declare;
 489         $version = &$qv_declare(1.2.3);
 490         ok("$version" == "v1.2.3", 'v-string initialized $qv_declare()');
 491     }
 492
 493     diag "Tests with real-world (malformed) data" unless $ENV{PERL_CORE};
 494
 495     # trailing zero testing (reported by Andreas Koenig).
 496     $version = $CLASS->$method("1");
 497     ok($version->numify eq "1.000", "trailing zeros preserved");
 498     $version = $CLASS->$method("1.0");
 499     ok($version->numify eq "1.000", "trailing zeros preserved");
 500     $version = $CLASS->$method("1.0.0");
 501     ok($version->numify eq "1.000000", "trailing zeros preserved");
 502     $version = $CLASS->$method("1.0.0.0");
 503     ok($version->numify eq "1.000000000", "trailing zeros preserved");
 504
 505     # leading zero testing (reported by Andreas Koenig).
 506     $version = $CLASS->$method(".7");
 507     ok($version->numify eq "0.700", "leading zero inferred");
 508
 509     # leading space testing (reported by Andreas Koenig).
 510     $version = $CLASS->$method(" 1.7");
 511     ok($version->numify eq "1.700", "leading space ignored");
 512
 513     # RT 19517 - deal with undef and 'undef' initialization
 514     ok("$version" ne 'undef', "Undef version comparison #1");
 515     ok("$version" ne undef, "Undef version comparison #2");
 516     $version = $CLASS->$method('undef');
 517     unlike($warning, qr/^Version string 'undef' contains invalid data/,
 518         "Version string 'undef'");
 519
 520     $version = $CLASS->$method(undef);
 521     like($warning, qr/^Use of uninitialized value/,
 522         "Version string 'undef'");
 523     ok($version == 'undef', "Undef version comparison #3");
 524     ok($version ==  undef,  "Undef version comparison #4");
 525     eval "\$version = \$CLASS->$method()"; # no parameter at all
 526     unlike($@, qr/^Bizarre copy of CODE/, "No initializer at all");
 527     ok($version == 'undef', "Undef version comparison #5");
 528     ok($version ==  undef,  "Undef version comparison #6");
 529
 530     $version = $CLASS->$method(0.000001);
 531     unlike($warning, qr/^Version string '1e-06' contains invalid data/,
 532         "Very small version objects");
 533     }
 534
 535 SKIP: {
 536         my $warning;
 537         local $SIG{__WARN__} = sub { $warning = $_[0] };
 538         # dummy up a legal module for testing RT#19017
 539         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 540         (my $package = basename($filename)) =~ s/\.pm$//;
 541         print $fh <<"EOF";
 542 package $package;
 543 use $CLASS; \$VERSION = ${CLASS}->new('0.0.4');
 544 1;
 545 EOF
 546         close $fh;
 547
 548         eval "use lib '.'; use $package 0.000008;";
 549         like ($@, qr/^$package version 0.000008 required/,
 550             "Make sure very small versions don't freak");
 551         eval "use lib '.'; use $package 1;";
 552         like ($@, qr/^$package version 1 required/,
 553             "Comparing vs. version with no decimal");
 554         eval "use lib '.'; use $package 1.;";
 555         like ($@, qr/^$package version 1 required/,
 556             "Comparing vs. version with decimal only");
 557         if ( $] < 5.006_000 ) {
 558             skip 'Cannot "use" extended versions with Perl < 5.6.0', 3;
 559         }
 560         eval "use lib '.'; use $package v0.0.8;";
 561         my $regex = "^$package version v0.0.8 required";
 562         like ($@, qr/$regex/, "Make sure very small versions don't freak");
 563
 564         $regex =~ s/8/4/; # set for second test
 565         eval "use lib '.'; use $package v0.0.4;";
 566         unlike($@, qr/$regex/, 'Succeed - required == VERSION');
 567         cmp_ok ( $package->VERSION, 'eq', '0.0.4', 'No undef warnings' );
 568         unlink $filename;
 569     }
 570
 571 SKIP: {
 572     skip 'Cannot test "use base qw(version)"  when require is used', 3
 573         unless defined $qv_declare;
 574     my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 575     (my $package = basename($filename)) =~ s/\.pm$//;
 576     print $fh <<"EOF";
 577 package $package;
 578 use base qw(version);
 579 1;
 580 EOF
 581     close $fh;
 582     # need to eliminate any other $qv_declare()'s
 583     undef *{"main\::$qv_declare"};
 584     ok(!defined(&{"main\::$qv_declare"}), "make sure we cleared $qv_declare() properly");
 585     eval "use lib '.'; use $package qw/declare qv/;";
 586     ok(defined(&{"main\::$qv_declare"}), "make sure we exported $qv_declare() properly");
 587     isa_ok( &$qv_declare(1.2), $package);
 588     unlink $filename;
 589 }
 590
 591 SKIP: {
 592         if ( $] < 5.006_000 ) {
 593             skip 'Cannot "use" extended versions with Perl < 5.6.0', 3;
 594         }
 595         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 596         (my $package = basename($filename)) =~ s/\.pm$//;
 597         print $fh <<"EOF";
 598 package $package;
 599 \$VERSION = 1.0;
 600 1;
 601 EOF
 602         close $fh;
 603         eval "use lib '.'; use $package 1.001;";
 604         like ($@, qr/^$package version 1.001 required/,
 605             "User typed numeric so we error with numeric");
 606         eval "use lib '.'; use $package v1.1.0;";
 607         like ($@, qr/^$package version v1.1.0 required/,
 608             "User typed extended so we error with extended");
 609         unlink $filename;
 610     }
 611
 612 SKIP: {
 613         # test locale handling
 614         my $warning;
 615         local $SIG{__WARN__} = sub { $warning = $_[0] };
 616
 617 $DB::single = 1;
 618         my $v = eval { $CLASS->$method('1,7') };
 619 #       is( $@, "", 'Directly test comma as decimal compliance');
 620
 621         my $ver = 1.23;  # has to be floating point number
 622         my $orig_loc = setlocale( LC_ALL );
 623         my $loc;
 624         while (<DATA>) {
 625             chomp;
 626             $loc = setlocale( LC_ALL, $_);
 627             last if localeconv()->{decimal_point} eq ',';
 628         }
 629         skip 'Cannot test locale handling without a comma locale', 4
 630             unless ( $loc and ($ver eq '1,23') );
 631
 632         diag ("Testing locale handling with $loc") unless $ENV{PERL_CORE};
 633
 634         $v = $CLASS->$method($ver);
 635         unlike($warning, qr/Version string '1,23' contains invalid data/,
 636             "Process locale-dependent floating point");
 637         is ($v, "1.23", "Locale doesn't apply to version objects");
 638         ok ($v == $ver, "Comparison to locale floating point");
 639
 640         setlocale( LC_ALL, $orig_loc); # reset this before possible skip
 641         skip 'Cannot test RT#46921 with Perl < 5.008', 1
 642             if ($] < 5.008);
 643         skip 'Cannot test RT#46921 with pure Perl module', 1
 644             if exists $INC{'version/vpp.pm'};
 645         my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
 646         (my $package = basename($filename)) =~ s/\.pm$//;
 647         print $fh <<"EOF";
 648 package $package;
 649 use POSIX qw(locale_h);
 650 \$^W = 1;
 651 use $CLASS;
 652 setlocale (LC_ALL, '$loc');
 653 use $CLASS ;
 654 eval "use Socket 1.7";
 655 setlocale( LC_ALL, '$orig_loc');
 656 1;
 657 EOF
 658         close $fh;
 659
 660         eval "use lib '.'; use $package;";
 661         unlike($warning, qr"Version string '1,7' contains invalid data",
 662             'Handle locale action-at-a-distance');
 663     }
 664
 665     eval 'my $v = $CLASS->$method("1._1");';
 666     unlike($@, qr/^Invalid version format \(alpha with zero width\)/,
 667         "Invalid version format 1._1");
 668
 669     {
 670         my $warning;
 671         local $SIG{__WARN__} = sub { $warning = $_[0] };
 672         eval 'my $v = $CLASS->$method(~0);';
 673         unlike($@, qr/Integer overflow in version/, "Too large version");
 674         like($warning, qr/Integer overflow in version/, "Too large version");
 675     }
 676
 677     {
 678         # http://rt.cpan.org/Public/Bug/Display.html?id=30004
 679         my $v1 = $CLASS->$method("v0.1_1");
 680         (my $alpha1 = Dumper($v1)) =~ s/.+'alpha' => ([^,]+),.+/$1/ms;
 681         my $v2 = $CLASS->$method($v1);
 682         (my $alpha2 = Dumper($v2)) =~ s/.+'alpha' => ([^,]+),.+/$1/ms;
 683         is $alpha2, $alpha1, "Don't fall for Data::Dumper's tricks";
 684     }
 685
 686     {
 687         # http://rt.perl.org/rt3/Ticket/Display.html?id=56606
 688         my $badv = bless { version => [1,2,3] }, "version";
 689         is $badv, '1.002003', "Deal with badly serialized versions from YAML";
 690         my $badv2 = bless { qv => 1, version => [1,2,3] }, "version";
 691         is $badv2, 'v1.2.3', "Deal with badly serialized versions from YAML ";
 692     }
 693 }
 694
 695 1;
 696
 697 __DATA__
 698 af_ZA
 699 af_ZA.utf8
 700 an_ES
 701 an_ES.utf8
 702 az_AZ.utf8
 703 be_BY
 704 be_BY.utf8
 705 bg_BG
 706 bg_BG.utf8
 707 br_FR
 708 br_FR@euro
 709 br_FR.utf8
 710 bs_BA
 711 bs_BA.utf8
 712 ca_ES
 713 ca_ES@euro
 714 ca_ES.utf8
 715 cs_CZ
 716 cs_CZ.utf8
 717 da_DK
 718 da_DK.utf8
 719 de_AT
 720 de_AT@euro
 721 de_AT.utf8
 722 de_BE
 723 de_BE@euro
 724 de_BE.utf8
 725 de_DE
 726 de_DE@euro
 727 de_DE.utf8
 728 de_LU
 729 de_LU@euro
 730 de_LU.utf8
 731 el_GR
 732 el_GR.utf8
 733 en_DK
 734 en_DK.utf8
 735 es_AR
 736 es_AR.utf8
 737 es_BO
 738 es_BO.utf8
 739 es_CL
 740 es_CL.utf8
 741 es_CO
 742 es_CO.utf8
 743 es_EC
 744 es_EC.utf8
 745 es_ES
 746 es_ES@euro
 747 es_ES.utf8
 748 es_PY
 749 es_PY.utf8
 750 es_UY
 751 es_UY.utf8
 752 es_VE
 753 es_VE.utf8
 754 et_EE
 755 et_EE.iso885915
 756 et_EE.utf8
 757 eu_ES
 758 eu_ES@euro
 759 eu_ES.utf8
 760 fi_FI
 761 fi_FI@euro
 762 fi_FI.utf8
 763 fo_FO
 764 fo_FO.utf8
 765 fr_BE
 766 fr_BE@euro
 767 fr_BE.utf8
 768 fr_CA
 769 fr_CA.utf8
 770 fr_CH
 771 fr_CH.utf8
 772 fr_FR
 773 fr_FR@euro
 774 fr_FR.utf8
 775 fr_LU
 776 fr_LU@euro
 777 fr_LU.utf8
 778 gl_ES
 779 gl_ES@euro
 780 gl_ES.utf8
 781 hr_HR
 782 hr_HR.utf8
 783 hu_HU
 784 hu_HU.utf8
 785 id_ID
 786 id_ID.utf8
 787 is_IS
 788 is_IS.utf8
 789 it_CH
 790 it_CH.utf8
 791 it_IT
 792 it_IT@euro
 793 it_IT.utf8
 794 ka_GE
 795 ka_GE.utf8
 796 kk_KZ
 797 kk_KZ.utf8
 798 kl_GL
 799 kl_GL.utf8
 800 lt_LT
 801 lt_LT.utf8
 802 lv_LV
 803 lv_LV.utf8
 804 mk_MK
 805 mk_MK.utf8
 806 mn_MN
 807 mn_MN.utf8
 808 nb_NO
 809 nb_NO.utf8
 810 nl_BE
 811 nl_BE@euro
 812 nl_BE.utf8
 813 nl_NL
 814 nl_NL@euro
 815 nl_NL.utf8
 816 nn_NO
 817 nn_NO.utf8
 818 no_NO
 819 no_NO.utf8
 820 oc_FR
 821 oc_FR.utf8
 822 pl_PL
 823 pl_PL.utf8
 824 pt_BR
 825 pt_BR.utf8
 826 pt_PT
 827 pt_PT@euro
 828 pt_PT.utf8
 829 ro_RO
 830 ro_RO.utf8
 831 ru_RU
 832 ru_RU.koi8r
 833 ru_RU.utf8
 834 ru_UA
 835 ru_UA.utf8
 836 se_NO
 837 se_NO.utf8
 838 sh_YU
 839 sh_YU.utf8
 840 sk_SK
 841 sk_SK.utf8
 842 sl_SI
 843 sl_SI.utf8
 844 sq_AL
 845 sq_AL.utf8
 846 sr_CS
 847 sr_CS.utf8
 848 sv_FI
 849 sv_FI@euro
 850 sv_FI.utf8
 851 sv_SE
 852 sv_SE.iso885915
 853 sv_SE.utf8
 854 tg_TJ
 855 tg_TJ.utf8
 856 tr_TR
 857 tr_TR.utf8
 858 tt_RU.utf8
 859 uk_UA
 860 uk_UA.utf8
 861 vi_VN
 862 vi_VN.tcvn
 863 wa_BE
 864 wa_BE@euro
 865 wa_BE.utf8
 866