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