Commit | Line | Data |
---|---|---|
543eec9e JP |
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; | |
0c1d6ad7 | 13 | use_ok("version", 0.9904); |
543eec9e JP |
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 | ||
543eec9e JP |
60 | use_ok($package, 0.001); |
61 | my $testobj = $package->new(1.002_003); | |
62 | isa_ok( $testobj, $package ); | |
63 | ok( $testobj->numify == 1.002003, "Numified correctly" ); | |
64 | ok( $testobj->stringify eq "1.002003", "Stringified correctly" ); | |
65 | ok( $testobj->normal eq "v1.2.3", "Normalified correctly" ); | |
66 | ||
67 | my $verobj = version::->new("1.2.4"); | |
68 | ok( $verobj > $testobj, "Comparison vs parent class" ); | |
69 | ||
70 | BaseTests($package, "new", "qv"); | |
71 | main_reset; | |
72 | use_ok($package, 0.001, "declare"); | |
73 | BaseTests($package, "new", "declare"); | |
74 | main_reset; | |
75 | use_ok($package, 0.001); | |
76 | BaseTests($package, "parse", "qv"); | |
77 | main_reset; | |
78 | use_ok($package, 0.001, "declare"); | |
79 | BaseTests($package, "parse", "declare"); | |
80 | ||
543eec9e JP |
81 | $testobj = version::Bad->new(1.002_003); |
82 | isa_ok( $testobj, "version::Bad" ); | |
83 | eval { my $string = $testobj->numify }; | |
84 | like($@, qr/Invalid version object/, | |
85 | "Bad subclass numify"); | |
86 | eval { my $string = $testobj->normal }; | |
87 | like($@, qr/Invalid version object/, | |
88 | "Bad subclass normal"); | |
89 | eval { my $string = $testobj->stringify }; | |
90 | like($@, qr/Invalid version object/, | |
91 | "Bad subclass stringify"); | |
92 | eval { my $test = ($testobj > 1.0) }; | |
93 | like($@, qr/Invalid version object/, | |
94 | "Bad subclass vcmp"); | |
95 | ||
96 | # Bad subclassing for SemVer with pure Perl version.pm only | |
97 | eval { my $test = version::Bad2->new("01.1.2") }; | |
98 | like($@, qr/Invalid version string format/, | |
99 | "Correctly found invalid version"); | |
100 | ||
101 | eval { my $test = version::Bad2->declare("01.1.2") }; | |
102 | unlike($@, qr/Invalid version string format/, | |
103 | "Correctly ignored invalid version"); |