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