lib/version.t

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