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