This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PATCH: Synchronize version.pm CPAN with core
[perl5.git] / cpan / version / t / 02derived.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 File::Temp qw/tempfile/;
9 my $Verbose;
10
11 BEGIN {
12     (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
13     require $coretests;
14     use_ok("version", 0.9903);
15     # If we made it this far, we are ok.
16 }
17
18 use lib qw/./;
19
20 package version::Bad;
21 use base 'version';
22 sub new { my($self,$n)=@_;  bless \$n, $self }
23
24 # Bad subclass for SemVer failures seen with pure Perl version.pm only
25 package version::Bad2;
26 use base 'version';
27 sub new {
28     my ($class, $val) = @_;
29     die 'Invalid version string format' unless version::is_strict($val);
30     my $self = $class->SUPER::new($val);
31     return $self;
32 }
33 sub declare {
34     my ($class, $val) = @_;
35     my $self = $class->SUPER::declare($val);
36     return $self;
37 }
38
39 package main;
40
41 my $warning;
42 local $SIG{__WARN__} = sub { $warning = $_[0] };
43 # dummy up a legal module for testing RT#19017
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"  if $Verbose;
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"  if $Verbose;
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 # Bad subclassing for SemVer with pure Perl version.pm only
101 eval { my $test = version::Bad2->new("01.1.2") };
102 like($@, qr/Invalid version string format/,
103     "Correctly found invalid version");
104
105 eval { my $test = version::Bad2->declare("01.1.2") };
106 unlike($@, qr/Invalid version string format/,
107     "Correctly ignored invalid version");