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