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