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