This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #95544] Make UNIVERSAL::VERSION return $VERSION
[perl5.git] / lib / version.t
CommitLineData
129318bd 1#! /usr/local/perl -w
a7ad731c 2
34ba6322 3use Test::More qw(no_plan);
72287d96 4use Data::Dumper;
c8a14fb6
RGS
5require Test::Harness;
6no warnings 'once';
7*Verbose = \$Test::Harness::Verbose;
f941e658
JP
8use POSIX qw/locale_h/;
9use File::Temp qw/tempfile/;
10use File::Basename;
a7ad731c 11
5eb567df 12BEGIN {
f941e658
JP
13 use_ok("version", 0.77);
14 # If we made it this far, we are ok.
5eb567df
RGS
15}
16
f941e658
JP
17my $Verbose;
18
19diag "Tests with base class" unless $ENV{PERL_CORE};
137d6fc0 20
f941e658
JP
21BaseTests("version","new","qv");
22BaseTests("version","new","declare");
23BaseTests("version","parse", "qv");
24BaseTests("version","parse", "declare");
137d6fc0 25
98dc9551 26# dummy up a redundant call to satisfy David Wheeler
f941e658
JP
27local $SIG{__WARN__} = sub { die $_[0] };
28eval 'use version;';
29unlike ($@, qr/^Subroutine main::declare redefined/,
30 "Only export declare once per package (to prevent redefined warnings).");
137d6fc0 31
e0218a61 32package version::Bad;
f941e658 33use base 'version';
e0218a61
JP
34sub new { my($self,$n)=@_; bless \$n, $self }
35
137d6fc0 36package main;
f941e658
JP
37
38my $warning;
39local $SIG{__WARN__} = sub { $warning = $_[0] };
40my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
41(my $package = basename($filename)) =~ s/\.pm$//;
42print $fh <<"EOF";
43# This is an empty subclass
44package $package;
45use base 'version';
46use vars '\$VERSION';
47\$VERSION=0.001;
48EOF
49close $fh;
50
51sub 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
57diag "Tests with empty derived class" unless $ENV{PERL_CORE};
58
59use_ok($package, 0.001);
60my $testobj = $package->new(1.002_003);
61isa_ok( $testobj, $package );
137d6fc0 62ok( $testobj->numify == 1.002003, "Numified correctly" );
9137345a
JP
63ok( $testobj->stringify eq "1.002003", "Stringified correctly" );
64ok( $testobj->normal eq "v1.2.3", "Normalified correctly" );
137d6fc0 65
f941e658 66my $verobj = version::->new("1.2.4");
137d6fc0 67ok( $verobj > $testobj, "Comparison vs parent class" );
137d6fc0 68
f941e658
JP
69BaseTests($package, "new", "qv");
70main_reset;
71use_ok($package, 0.001, "declare");
72BaseTests($package, "new", "declare");
73main_reset;
74use_ok($package, 0.001);
75BaseTests($package, "parse", "qv");
76main_reset;
77use_ok($package, 0.001, "declare");
78BaseTests($package, "parse", "declare");
79
80diag "tests with bad subclass" unless $ENV{PERL_CORE};
e0218a61
JP
81$testobj = version::Bad->new(1.002_003);
82isa_ok( $testobj, "version::Bad" );
83eval { my $string = $testobj->numify };
84like($@, qr/Invalid version object/,
85 "Bad subclass numify");
86eval { my $string = $testobj->normal };
87like($@, qr/Invalid version object/,
88 "Bad subclass normal");
89eval { my $string = $testobj->stringify };
90like($@, qr/Invalid version object/,
91 "Bad subclass stringify");
f941e658 92eval { my $test = ($testobj > 1.0) };
e0218a61
JP
93like($@, qr/Invalid version object/,
94 "Bad subclass vcmp");
5de8bffd
DG
95
96# Invalid structure
97eval { $a = \\version->new(1); bless $a, "version"; print "# $a\n" };
98like($@, qr/Invalid version object/,
99 "Bad internal structure (RT#78286)");
9b463b21
DG
100
101# do strict lax tests in a sub to isolate a package to test importing
5de8bffd
DG
102strict_lax_tests();
103
9b463b21
DG
104sub 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';
1091.00 pass pass
1101.00001 pass pass
1110.123 pass pass
11212.345 pass pass
11342 pass pass
1140 pass pass
1150.0 pass pass
116v1.2.3 pass pass
117v1.2.3.4 pass pass
118v0.1.2 pass pass
119v0.0.0 pass pass
12001 fail pass
12101.0203 fail pass
122v01 fail pass
123v01.02.03 fail pass
124.1 fail pass
125.1.2 fail pass
1261. fail pass
1271.a fail fail
1281._ fail fail
1291.02_03 fail pass
130v1.2_3 fail pass
131v1.02_03 fail pass
132v1.2_3_4 fail fail
133v1.2_3.4 fail fail
1341.2_3.4 fail fail
1350_ fail fail
1361_ fail fail
1371_. fail fail
1381.1_ fail fail
1391.02_03_04 fail fail
1401.2.3 fail pass
141v1.2 fail pass
142v0 fail pass
143v1 fail pass
144v.1.2.3 fail fail
145v fail fail
146v1.2345.6 fail pass
147undef fail pass
1481a fail fail
1491.2a3 fail fail
150bar fail fail
151_ fail fail
152CASE_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}
e0218a61 164
137d6fc0
JP
165sub BaseTests {
166
f941e658 167 my ($CLASS, $method, $qv_declare) = @_;
692a467c
JP
168 my $warning;
169 local $SIG{__WARN__} = sub { $warning = $_[0] };
317f7c8a
RGS
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
f941e658
JP
175 diag "tests with bare numbers" unless $ENV{PERL_CORE};
176 $version = $CLASS->$method(5.005_03);
8cb289bd 177 is ( "$version" , "5.00503" , '5.005_03 eq 5.00503' );
f941e658 178 $version = $CLASS->$method(1.23);
8cb289bd 179 is ( "$version" , "1.23" , '1.23 eq "1.23"' );
317f7c8a
RGS
180
181 # Test quoted number processing
f941e658
JP
182 diag "tests with quoted numbers" unless $ENV{PERL_CORE};
183 $version = $CLASS->$method("5.005_03");
8cb289bd 184 is ( "$version" , "5.005_03" , '"5.005_03" eq "5.005_03"' );
f941e658 185 $version = $CLASS->$method("v1.23");
8cb289bd 186 is ( "$version" , "v1.23" , '"v1.23" eq "v1.23"' );
317f7c8a
RGS
187
188 # Test stringify operator
f941e658
JP
189 diag "tests with stringify" unless $ENV{PERL_CORE};
190 $version = $CLASS->$method("5.005");
317f7c8a 191 is ( "$version" , "5.005" , '5.005 eq "5.005"' );
f941e658 192 $version = $CLASS->$method("5.006.001");
8cb289bd 193 is ( "$version" , "5.006.001" , '5.006.001 eq v5.6.1' );
692a467c
JP
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' );
317f7c8a
RGS
197
198 # test illegal formats
f941e658 199 diag "test illegal formats" unless $ENV{PERL_CORE};
d54f8cf7 200 eval {my $version = $CLASS->$method("1.2_3_4")};
317f7c8a
RGS
201 like($@, qr/multiple underscores/,
202 "Invalid version format (multiple underscores)");
203
d54f8cf7 204 eval {my $version = $CLASS->$method("1.2_3.4")};
317f7c8a
RGS
205 like($@, qr/underscores before decimal/,
206 "Invalid version format (underscores before decimal)");
207
d54f8cf7 208 eval {my $version = $CLASS->$method("1_2")};
317f7c8a
RGS
209 like($@, qr/alpha without decimal/,
210 "Invalid version format (alpha without decimal)");
211
91152fc1
DG
212 eval { $version = $CLASS->$method("1.2b3")};
213 like($@, qr/non-numeric data/,
214 "Invalid version format (non-numeric data)");
317f7c8a 215
c8c8e589
JP
216 eval { $version = $CLASS->$method("-1.23")};
217 like($@, qr/negative version number/,
218 "Invalid version format (negative version number)");
219
317f7c8a 220 # from here on out capture the warning and test independently
f34c6aaf 221 {
91152fc1 222 eval{$version = $CLASS->$method("99 and 44/100 pure")};
317f7c8a 223
91152fc1
DG
224 like($@, qr/non-numeric data/,
225 "Invalid version format (non-numeric data)");
317f7c8a 226
91152fc1
DG
227 eval{$version = $CLASS->$method("something")};
228 like($@, qr/non-numeric data/,
229 "Invalid version format (non-numeric data)");
317f7c8a
RGS
230
231 # reset the test object to something reasonable
f941e658 232 $version = $CLASS->$method("1.2.3");
317f7c8a
RGS
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
f941e658 241 diag "tests with self" unless $ENV{PERL_CORE};
8cb289bd 242 is ( $version <=> $version, 0, '$version <=> $version == 0' );
317f7c8a
RGS
243 ok ( $version == $version, '$version == $version' );
244
317f7c8a
RGS
245 # Test Numeric Comparison operators
246 # test first with non-object
f941e658 247 $version = $CLASS->$method("5.006.001");
317f7c8a 248 $new_version = "5.8.0";
f941e658 249 diag "numeric tests with non-objects" unless $ENV{PERL_CORE};
317f7c8a
RGS
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
f941e658
JP
256 $new_version = $CLASS->$method($new_version);
257 diag "numeric tests with objects" unless $ENV{PERL_CORE};
317f7c8a
RGS
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
f941e658 263 diag "numeric tests with numbers" unless $ENV{PERL_CORE};
317f7c8a
RGS
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
f941e658
JP
270 diag "Tests with extended decimal versions" unless $ENV{PERL_CORE};
271 $version = $CLASS->$method(1.002003);
8cb289bd 272 ok ( $version == "1.2.3", '$version == "1.2.3"');
317f7c8a 273 ok ( $version->numify == 1.002003, '$version->numify == 1.002003');
f941e658 274 $version = $CLASS->$method("2002.09.30.1");
8cb289bd 275 ok ( $version == "2002.9.30.1",'$version == 2002.9.30.1');
317f7c8a
RGS
276 ok ( $version->numify == 2002.009030001,
277 '$version->numify == 2002.009030001');
278
279 # now test with alpha version form with string
f941e658 280 $version = $CLASS->$method("1.2.3");
317f7c8a 281 $new_version = "1.2.3_4";
f941e658 282 diag "numeric tests with alpha-style non-objects" unless $ENV{PERL_CORE};
8cb289bd
RGS
283 ok ( $version < $new_version, '$version < $new_version' );
284 ok ( $new_version > $version, '$new_version > $version' );
285 ok ( $version != $new_version, '$version != $new_version' );
317f7c8a 286
f941e658 287 $version = $CLASS->$method("1.2.4");
317f7c8a 288 diag "numeric tests with alpha-style non-objects"
692a467c 289 unless $ENV{PERL_CORE};
317f7c8a
RGS
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
f941e658
JP
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};
317f7c8a
RGS
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
f941e658
JP
304 $version = $CLASS->$method("1.2.4");
305 diag "tests with alpha-style objects" unless $ENV{PERL_CORE};
317f7c8a
RGS
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
f941e658
JP
310 $version = $CLASS->$method("1.2.3.4");
311 $new_version = $CLASS->$method("1.2.3_4");
317f7c8a 312 diag "tests with alpha-style objects with same subversion"
692a467c 313 unless $ENV{PERL_CORE};
317f7c8a
RGS
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
f941e658
JP
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");
317f7c8a 321 ok ( $version == $new_version, '$version == $new_version' );
f941e658 322 $new_version = $CLASS->$method("1.2.3_0");
317f7c8a 323 ok ( $version == $new_version, '$version == $new_version' );
f941e658 324 $new_version = $CLASS->$method("1.2.3.1");
317f7c8a 325 ok ( $version < $new_version, '$version < $new_version' );
f941e658 326 $new_version = $CLASS->$method("1.2.3_1");
317f7c8a 327 ok ( $version < $new_version, '$version < $new_version' );
f941e658 328 $new_version = $CLASS->$method("1.1.999");
317f7c8a
RGS
329 ok ( $version > $new_version, '$version > $new_version' );
330
331 # that which is not expressly permitted is forbidden
f941e658 332 diag "forbidden operations" unless $ENV{PERL_CORE};
317f7c8a
RGS
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" );
137d6fc0 338
c8a14fb6 339SKIP: {
f941e658
JP
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 );
c8a14fb6 349}
137d6fc0 350
317f7c8a 351 # test creation from existing version object
f941e658
JP
352 diag "create new from existing version" unless $ENV{PERL_CORE};
353 ok (eval {$new_version = $CLASS->$method($version)},
317f7c8a 354 "new from existing object");
f941e658 355 ok ($new_version == $version, "class->$method($version) identical");
d54f8cf7 356 $new_version = $version->$method(0);
317f7c8a 357 isa_ok ($new_version, $CLASS );
f941e658
JP
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');
317f7c8a
RGS
361
362 # test the CVS revision mode
f941e658 363 diag "testing CVS Revision" unless $ENV{PERL_CORE};
317f7c8a 364 $version = new $CLASS qw$Revision: 1.2$;
8cb289bd 365 ok ( $version == "1.2.0", 'qw$Revision: 1.2$ == 1.2.0' );
317f7c8a 366 $version = new $CLASS qw$Revision: 1.2.3.4$;
8cb289bd 367 ok ( $version == "1.2.3.4", 'qw$Revision: 1.2.3.4$ == 1.2.3.4' );
317f7c8a
RGS
368
369 # test the CPAN style reduced significant digit form
f941e658
JP
370 diag "testing CPAN-style versions" unless $ENV{PERL_CORE};
371 $version = $CLASS->$method("1.23_01");
8cb289bd 372 is ( "$version" , "1.23_01", "CPAN-style alpha version" );
317f7c8a
RGS
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
f941e658 377 diag "Replacement UNIVERSAL::VERSION tests" unless $ENV{PERL_CORE};
f34c6aaf
JP
378
379 my $error_regex = $] < 5.006
380 ? 'version \d required'
f941e658 381 : 'does not define \$t.{7}::VERSION';
317f7c8a 382
f34c6aaf 383 {
f941e658
JP
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;
f34c6aaf 388
8cb289bd 389 $version = 0.58;
f941e658
JP
390 eval "use lib '.'; use $package $version";
391 unlike($@, qr/$package version $version/,
f34c6aaf
JP
392 'Replacement eval works with exact version');
393
394 # test as class method
f941e658 395 $new_version = $package->VERSION;
8cb289bd 396 cmp_ok($new_version,'==',$version, "Called as class method");
8dd04980 397
f34c6aaf
JP
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
8cb289bd 409 $version += 0.01;
f941e658
JP
410 eval "use lib '.'; use $package $version";
411 like($@, qr/$package version $version/,
f34c6aaf
JP
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
f941e658
JP
416 eval "use lib '.'; use $package $version";
417 unlike($@, qr/$package version $version/,
f34c6aaf
JP
418 'Replacement eval works with single digit');
419
420 # this would fail with old UNIVERSAL::VERSION
8cb289bd 421 $version += 0.1;
f941e658
JP
422 eval "use lib '.'; use $package $version";
423 like($@, qr/$package version $version/,
f34c6aaf 424 'Replacement eval works with incremented digit');
f941e658 425 unlink $filename;
f34c6aaf 426 }
317f7c8a
RGS
427
428 { # dummy up some variously broken modules for testing
f941e658
JP
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;
f34c6aaf 433
f941e658 434 eval "use lib '.'; use $package 3;";
317f7c8a 435 if ( $] < 5.008 ) {
f34c6aaf
JP
436 like($@, qr/$error_regex/,
437 'Replacement handles modules without package or VERSION');
c8a14fb6 438 }
317f7c8a 439 else {
f34c6aaf
JP
440 like($@, qr/defines neither package nor VERSION/,
441 'Replacement handles modules without package or VERSION');
c8a14fb6 442 }
f941e658 443 eval "use lib '.'; use $package; \$version = $package->VERSION";
317f7c8a
RGS
444 unlike ($@, qr/$error_regex/,
445 'Replacement handles modules without package or VERSION');
f34c6aaf 446 ok (!defined($version), "Called as class method");
f941e658 447 unlink $filename;
317f7c8a
RGS
448 }
449
450 { # dummy up some variously broken modules for testing
f941e658
JP
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;";
f34c6aaf 456 like ($@, qr/$error_regex/,
317f7c8a 457 'Replacement handles modules without VERSION');
f941e658 458 eval "use lib '.'; use $package; print $package->VERSION";
f34c6aaf 459 unlike ($@, qr/$error_regex/,
317f7c8a 460 'Replacement handles modules without VERSION');
f941e658 461 unlink $filename;
317f7c8a
RGS
462 }
463
464 { # dummy up some variously broken modules for testing
f941e658
JP
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;";
f34c6aaf 470 like ($@, qr/$error_regex/,
317f7c8a 471 'Replacement handles modules without VERSION');
f941e658 472 eval "use lib '.'; use $package; print $package->VERSION";
f34c6aaf 473 unlike ($@, qr/$error_regex/,
317f7c8a 474 'Replacement handles modules without VERSION');
f941e658 475 unlink $filename;
317f7c8a
RGS
476 }
477
137d6fc0 478SKIP: {
ac0e6a2f
RGS
479 skip 'Cannot test bare v-strings with Perl < 5.6.0', 4
480 if $] < 5.006_000;
f941e658
JP
481 diag "Tests with v-strings" unless $ENV{PERL_CORE};
482 $version = $CLASS->$method(1.2.3);
d54f8cf7 483 ok("$version" eq "v1.2.3", '"$version" eq 1.2.3');
f941e658
JP
484 $version = $CLASS->$method(1.0.0);
485 $new_version = $CLASS->$method(1);
317f7c8a 486 ok($version == $new_version, '$version == $new_version');
f941e658
JP
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);
d54f8cf7
JP
490 ok("$version" eq "v1.2.3", 'v-string initialized $qv_declare()');
491 }
492
493SKIP: {
494 skip 'Cannot test bare alpha v-strings with Perl < 5.8.1', 2
495 if $] lt 5.008_001;
496 diag "Tests with bare alpha v-strings" unless $ENV{PERL_CORE};
497 $version = $CLASS->$method(v1.2.3_4);
498 is($version, "v1.2.3_4", '"$version" eq "v1.2.3_4"');
499 $version = $CLASS->$method(eval "v1.2.3_4");
500 is($version, "v1.2.3_4", '"$version" eq "v1.2.3_4" (from eval)');
317f7c8a
RGS
501 }
502
f941e658 503 diag "Tests with real-world (malformed) data" unless $ENV{PERL_CORE};
317f7c8a
RGS
504
505 # trailing zero testing (reported by Andreas Koenig).
f941e658 506 $version = $CLASS->$method("1");
317f7c8a 507 ok($version->numify eq "1.000", "trailing zeros preserved");
f941e658 508 $version = $CLASS->$method("1.0");
317f7c8a 509 ok($version->numify eq "1.000", "trailing zeros preserved");
f941e658 510 $version = $CLASS->$method("1.0.0");
317f7c8a 511 ok($version->numify eq "1.000000", "trailing zeros preserved");
f941e658 512 $version = $CLASS->$method("1.0.0.0");
317f7c8a
RGS
513 ok($version->numify eq "1.000000000", "trailing zeros preserved");
514
515 # leading zero testing (reported by Andreas Koenig).
f941e658 516 $version = $CLASS->$method(".7");
317f7c8a
RGS
517 ok($version->numify eq "0.700", "leading zero inferred");
518
519 # leading space testing (reported by Andreas Koenig).
f941e658 520 $version = $CLASS->$method(" 1.7");
317f7c8a
RGS
521 ok($version->numify eq "1.700", "leading space ignored");
522
523 # RT 19517 - deal with undef and 'undef' initialization
8cb289bd
RGS
524 ok("$version" ne 'undef', "Undef version comparison #1");
525 ok("$version" ne undef, "Undef version comparison #2");
f941e658 526 $version = $CLASS->$method('undef');
317f7c8a
RGS
527 unlike($warning, qr/^Version string 'undef' contains invalid data/,
528 "Version string 'undef'");
529
f941e658 530 $version = $CLASS->$method(undef);
317f7c8a
RGS
531 like($warning, qr/^Use of uninitialized value/,
532 "Version string 'undef'");
8cb289bd
RGS
533 ok($version == 'undef', "Undef version comparison #3");
534 ok($version == undef, "Undef version comparison #4");
f941e658 535 eval "\$version = \$CLASS->$method()"; # no parameter at all
317f7c8a 536 unlike($@, qr/^Bizarre copy of CODE/, "No initializer at all");
8cb289bd
RGS
537 ok($version == 'undef', "Undef version comparison #5");
538 ok($version == undef, "Undef version comparison #6");
317f7c8a 539
f941e658 540 $version = $CLASS->$method(0.000001);
317f7c8a
RGS
541 unlike($warning, qr/^Version string '1e-06' contains invalid data/,
542 "Very small version objects");
f34c6aaf 543 }
e0218a61 544
317f7c8a 545SKIP: {
f941e658
JP
546 my $warning;
547 local $SIG{__WARN__} = sub { $warning = $_[0] };
317f7c8a 548 # dummy up a legal module for testing RT#19017
f941e658
JP
549 my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
550 (my $package = basename($filename)) =~ s/\.pm$//;
551 print $fh <<"EOF";
552package $package;
553use $CLASS; \$VERSION = ${CLASS}->new('0.0.4');
c8a14fb6
RGS
5541;
555EOF
f941e658 556 close $fh;
317f7c8a 557
f941e658
JP
558 eval "use lib '.'; use $package 0.000008;";
559 like ($@, qr/^$package version 0.000008 required/,
317f7c8a 560 "Make sure very small versions don't freak");
f941e658
JP
561 eval "use lib '.'; use $package 1;";
562 like ($@, qr/^$package version 1 required/,
317f7c8a 563 "Comparing vs. version with no decimal");
f941e658
JP
564 eval "use lib '.'; use $package 1.;";
565 like ($@, qr/^$package version 1 required/,
317f7c8a 566 "Comparing vs. version with decimal only");
ac0e6a2f 567 if ( $] < 5.006_000 ) {
ac0e6a2f 568 skip 'Cannot "use" extended versions with Perl < 5.6.0', 3;
d69f6151 569 }
f941e658
JP
570 eval "use lib '.'; use $package v0.0.8;";
571 my $regex = "^$package version v0.0.8 required";
ac0e6a2f 572 like ($@, qr/$regex/, "Make sure very small versions don't freak");
317f7c8a 573
ac0e6a2f 574 $regex =~ s/8/4/; # set for second test
f941e658 575 eval "use lib '.'; use $package v0.0.4;";
ac0e6a2f 576 unlike($@, qr/$regex/, 'Succeed - required == VERSION');
f941e658
JP
577 cmp_ok ( $package->VERSION, 'eq', '0.0.4', 'No undef warnings' );
578 unlink $filename;
317f7c8a
RGS
579 }
580
f941e658
JP
581SKIP: {
582 skip 'Cannot test "use base qw(version)" when require is used', 3
583 unless defined $qv_declare;
584 my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
585 (my $package = basename($filename)) =~ s/\.pm$//;
586 print $fh <<"EOF";
587package $package;
92dcf8ce
JP
588use base qw(version);
5891;
590EOF
f941e658
JP
591 close $fh;
592 # need to eliminate any other $qv_declare()'s
593 undef *{"main\::$qv_declare"};
594 ok(!defined(&{"main\::$qv_declare"}), "make sure we cleared $qv_declare() properly");
595 eval "use lib '.'; use $package qw/declare qv/;";
596 ok(defined(&{"main\::$qv_declare"}), "make sure we exported $qv_declare() properly");
597 isa_ok( &$qv_declare(1.2), $package);
598 unlink $filename;
599}
d69f6151
JP
600
601SKIP: {
ac0e6a2f
RGS
602 if ( $] < 5.006_000 ) {
603 skip 'Cannot "use" extended versions with Perl < 5.6.0', 3;
604 }
f941e658
JP
605 my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
606 (my $package = basename($filename)) =~ s/\.pm$//;
607 print $fh <<"EOF";
608package $package;
ac0e6a2f
RGS
609\$VERSION = 1.0;
6101;
611EOF
f941e658
JP
612 close $fh;
613 eval "use lib '.'; use $package 1.001;";
614 like ($@, qr/^$package version 1.001 required/,
ac0e6a2f 615 "User typed numeric so we error with numeric");
f941e658
JP
616 eval "use lib '.'; use $package v1.1.0;";
617 like ($@, qr/^$package version v1.1.0 required/,
ac0e6a2f 618 "User typed extended so we error with extended");
f941e658 619 unlink $filename;
ac0e6a2f
RGS
620 }
621
622SKIP: {
d69f6151 623 # test locale handling
f34c6aaf
JP
624 my $warning;
625 local $SIG{__WARN__} = sub { $warning = $_[0] };
f941e658
JP
626
627$DB::single = 1;
91152fc1
DG
628 my $v = eval { $CLASS->$method('1,7') };
629# is( $@, "", 'Directly test comma as decimal compliance');
f941e658 630
d69f6151 631 my $ver = 1.23; # has to be floating point number
f941e658 632 my $orig_loc = setlocale( LC_ALL );
d69f6151
JP
633 my $loc;
634 while (<DATA>) {
635 chomp;
f941e658
JP
636 $loc = setlocale( LC_ALL, $_);
637 last if localeconv()->{decimal_point} eq ',';
d69f6151
JP
638 }
639 skip 'Cannot test locale handling without a comma locale', 4
640 unless ( $loc and ($ver eq '1,23') );
641
f941e658 642 diag ("Testing locale handling with $loc") unless $ENV{PERL_CORE};
d69f6151 643
f941e658
JP
644 $v = $CLASS->$method($ver);
645 unlike($warning, qr/Version string '1,23' contains invalid data/,
d69f6151 646 "Process locale-dependent floating point");
8cb289bd 647 is ($v, "1.23", "Locale doesn't apply to version objects");
d69f6151 648 ok ($v == $ver, "Comparison to locale floating point");
f941e658
JP
649
650 setlocale( LC_ALL, $orig_loc); # reset this before possible skip
651 skip 'Cannot test RT#46921 with Perl < 5.008', 1
652 if ($] < 5.008);
653 skip 'Cannot test RT#46921 with pure Perl module', 1
654 if exists $INC{'version/vpp.pm'};
655 my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
656 (my $package = basename($filename)) =~ s/\.pm$//;
657 print $fh <<"EOF";
658package $package;
659use POSIX qw(locale_h);
660\$^W = 1;
661use $CLASS;
662setlocale (LC_ALL, '$loc');
663use $CLASS ;
664eval "use Socket 1.7";
665setlocale( LC_ALL, '$orig_loc');
6661;
667EOF
668 close $fh;
669
670 eval "use lib '.'; use $package;";
671 unlike($warning, qr"Version string '1,7' contains invalid data",
672 'Handle locale action-at-a-distance');
d69f6151 673 }
f34c6aaf 674
f941e658 675 eval 'my $v = $CLASS->$method("1._1");';
f34c6aaf
JP
676 unlike($@, qr/^Invalid version format \(alpha with zero width\)/,
677 "Invalid version format 1._1");
ac0e6a2f 678
c812d146
JP
679 {
680 my $warning;
681 local $SIG{__WARN__} = sub { $warning = $_[0] };
f941e658 682 eval 'my $v = $CLASS->$method(~0);';
c812d146
JP
683 unlike($@, qr/Integer overflow in version/, "Too large version");
684 like($warning, qr/Integer overflow in version/, "Too large version");
685 }
686
72287d96
JP
687 {
688 # http://rt.cpan.org/Public/Bug/Display.html?id=30004
f941e658 689 my $v1 = $CLASS->$method("v0.1_1");
72287d96 690 (my $alpha1 = Dumper($v1)) =~ s/.+'alpha' => ([^,]+),.+/$1/ms;
f941e658 691 my $v2 = $CLASS->$method($v1);
72287d96
JP
692 (my $alpha2 = Dumper($v2)) =~ s/.+'alpha' => ([^,]+),.+/$1/ms;
693 is $alpha2, $alpha1, "Don't fall for Data::Dumper's tricks";
694 }
695
219bf418
RGS
696 {
697 # http://rt.perl.org/rt3/Ticket/Display.html?id=56606
698 my $badv = bless { version => [1,2,3] }, "version";
699 is $badv, '1.002003', "Deal with badly serialized versions from YAML";
700 my $badv2 = bless { qv => 1, version => [1,2,3] }, "version";
701 is $badv2, 'v1.2.3', "Deal with badly serialized versions from YAML ";
702 }
d54f8cf7
JP
703SKIP: {
704 if ( $] < 5.006_000 ) {
705 skip 'No v-string support at all < 5.6.0', 2;
706 }
707 # https://rt.cpan.org/Ticket/Display.html?id=49348
708 my $v = $CLASS->$method("420");
709 is "$v", "420", 'Correctly guesses this is not a v-string';
710 $v = $CLASS->$method(4.2.0);
711 is "$v", 'v4.2.0', 'Correctly guess that this is a v-string';
712 }
713SKIP: {
714 if ( $] < 5.006_000 ) {
715 skip 'No v-string support at all < 5.6.0', 4;
716 }
717 # https://rt.cpan.org/Ticket/Display.html?id=50347
718 # Check that the qv() implementation does not change
719
720 ok $CLASS->$method(1.2.3) < $CLASS->$method(1.2.3.1), 'Compare 3 and 4 digit v-strings' ;
721 ok $CLASS->$method(v1.2.3) < $CLASS->$method(v1.2.3.1), 'Compare 3 and 4 digit v-strings, leaving v';
722 ok $CLASS->$method("1.2.3") < $CLASS->$method("1.2.3.1"), 'Compare 3 and 4 digit v-strings, quoted';
723 ok $CLASS->$method("v1.2.3") < $CLASS->$method("v1.2.3.1"), 'Compare 3 and 4 digit v-strings, quoted leading v';
724 }
137d6fc0 725}
cb5772bb
RGS
726
7271;
d69f6151
JP
728
729__DATA__
730af_ZA
731af_ZA.utf8
732an_ES
733an_ES.utf8
734az_AZ.utf8
735be_BY
736be_BY.utf8
737bg_BG
738bg_BG.utf8
739br_FR
740br_FR@euro
741br_FR.utf8
742bs_BA
743bs_BA.utf8
744ca_ES
745ca_ES@euro
746ca_ES.utf8
747cs_CZ
748cs_CZ.utf8
749da_DK
750da_DK.utf8
751de_AT
752de_AT@euro
753de_AT.utf8
754de_BE
755de_BE@euro
756de_BE.utf8
757de_DE
758de_DE@euro
759de_DE.utf8
760de_LU
761de_LU@euro
762de_LU.utf8
763el_GR
764el_GR.utf8
765en_DK
766en_DK.utf8
767es_AR
768es_AR.utf8
769es_BO
770es_BO.utf8
771es_CL
772es_CL.utf8
773es_CO
774es_CO.utf8
775es_EC
776es_EC.utf8
777es_ES
778es_ES@euro
779es_ES.utf8
780es_PY
781es_PY.utf8
782es_UY
783es_UY.utf8
784es_VE
785es_VE.utf8
786et_EE
787et_EE.iso885915
788et_EE.utf8
789eu_ES
790eu_ES@euro
791eu_ES.utf8
792fi_FI
793fi_FI@euro
794fi_FI.utf8
795fo_FO
796fo_FO.utf8
797fr_BE
798fr_BE@euro
799fr_BE.utf8
800fr_CA
801fr_CA.utf8
802fr_CH
803fr_CH.utf8
804fr_FR
805fr_FR@euro
806fr_FR.utf8
807fr_LU
808fr_LU@euro
809fr_LU.utf8
810gl_ES
811gl_ES@euro
812gl_ES.utf8
813hr_HR
814hr_HR.utf8
815hu_HU
816hu_HU.utf8
817id_ID
818id_ID.utf8
819is_IS
820is_IS.utf8
821it_CH
822it_CH.utf8
823it_IT
824it_IT@euro
825it_IT.utf8
826ka_GE
827ka_GE.utf8
828kk_KZ
829kk_KZ.utf8
830kl_GL
831kl_GL.utf8
832lt_LT
833lt_LT.utf8
834lv_LV
835lv_LV.utf8
836mk_MK
837mk_MK.utf8
838mn_MN
839mn_MN.utf8
840nb_NO
841nb_NO.utf8
842nl_BE
843nl_BE@euro
844nl_BE.utf8
845nl_NL
846nl_NL@euro
847nl_NL.utf8
848nn_NO
849nn_NO.utf8
850no_NO
851no_NO.utf8
852oc_FR
853oc_FR.utf8
854pl_PL
855pl_PL.utf8
856pt_BR
857pt_BR.utf8
858pt_PT
859pt_PT@euro
860pt_PT.utf8
861ro_RO
862ro_RO.utf8
863ru_RU
864ru_RU.koi8r
865ru_RU.utf8
866ru_UA
867ru_UA.utf8
868se_NO
869se_NO.utf8
870sh_YU
871sh_YU.utf8
872sk_SK
873sk_SK.utf8
874sl_SI
875sl_SI.utf8
876sq_AL
877sq_AL.utf8
878sr_CS
879sr_CS.utf8
880sv_FI
881sv_FI@euro
882sv_FI.utf8
883sv_SE
884sv_SE.iso885915
885sv_SE.utf8
886tg_TJ
887tg_TJ.utf8
888tr_TR
889tr_TR.utf8
890tt_RU.utf8
891uk_UA
892uk_UA.utf8
893vi_VN
894vi_VN.tcvn
895wa_BE
896wa_BE@euro
897wa_BE.utf8
898