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