This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move version from lib/ to cpan/
[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
10 BEGIN {
11     (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
12     require $coretests;
13     use_ok("version", 0.9902);
14     # If we made it this far, we are ok.
15 }
16
17 use lib qw/./;
18
19 package version::Bad;
20 use base 'version';
21 sub new { my($self,$n)=@_;  bless \$n, $self }
22
23 # Bad subclass for SemVer failures seen with pure Perl version.pm only
24 package version::Bad2;
25 use base 'version';
26 sub new {
27     my ($class, $val) = @_;
28     die 'Invalid version string format' unless version::is_strict($val);
29     my $self = $class->SUPER::new($val);
30     return $self;
31 }
32 sub declare {
33     my ($class, $val) = @_;
34     my $self = $class->SUPER::declare($val);
35     return $self;
36 }
37
38 package main;
39
40 my $warning;
41 local $SIG{__WARN__} = sub { $warning = $_[0] };
42 # dummy up a legal module for testing RT#19017
43 my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
44 (my $package = basename($filename)) =~ s/\.pm$//;
45 print $fh <<"EOF";
46 # This is an empty subclass
47 package $package;
48 use base 'version';
49 use vars '\$VERSION';
50 \$VERSION=0.001;
51 EOF
52 close $fh;
53
54 sub main_reset {
55     delete $main::INC{'$package'};
56     undef &qv; undef *::qv; # avoid 'used once' warning
57     undef &declare; undef *::declare; # avoid 'used once' warning
58 }
59
60 diag "Tests with empty derived class"  unless $ENV{PERL_CORE};
61
62 use_ok($package, 0.001);
63 my $testobj = $package->new(1.002_003);
64 isa_ok( $testobj, $package );
65 ok( $testobj->numify == 1.002003, "Numified correctly" );
66 ok( $testobj->stringify eq "1.002003", "Stringified correctly" );
67 ok( $testobj->normal eq "v1.2.3", "Normalified correctly" );
68
69 my $verobj = version::->new("1.2.4");
70 ok( $verobj > $testobj, "Comparison vs parent class" );
71
72 BaseTests($package, "new", "qv");
73 main_reset;
74 use_ok($package, 0.001, "declare");
75 BaseTests($package, "new", "declare");
76 main_reset;
77 use_ok($package, 0.001);
78 BaseTests($package, "parse", "qv");
79 main_reset;
80 use_ok($package, 0.001, "declare");
81 BaseTests($package, "parse", "declare");
82
83 diag "tests with bad subclass"  unless $ENV{PERL_CORE};
84 $testobj = version::Bad->new(1.002_003);
85 isa_ok( $testobj, "version::Bad" );
86 eval { my $string = $testobj->numify };
87 like($@, qr/Invalid version object/,
88     "Bad subclass numify");
89 eval { my $string = $testobj->normal };
90 like($@, qr/Invalid version object/,
91     "Bad subclass normal");
92 eval { my $string = $testobj->stringify };
93 like($@, qr/Invalid version object/,
94     "Bad subclass stringify");
95 eval { my $test = ($testobj > 1.0) };
96 like($@, qr/Invalid version object/,
97     "Bad subclass vcmp");
98
99 # Bad subclassing for SemVer with pure Perl version.pm only
100 eval { my $test = version::Bad2->new("01.1.2") };
101 like($@, qr/Invalid version string format/,
102     "Correctly found invalid version");
103
104 eval { my $test = version::Bad2->declare("01.1.2") };
105 unlike($@, qr/Invalid version string format/,
106     "Correctly ignored invalid version");