| 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; |
| 13 | use_ok("version", 0.9909); |
| 14 | # If we made it this far, we are ok. |
| 15 | } |
| 16 | |
| 17 | use lib qw/./; |
| 18 | |
| 19 | package version::Bad; |
| 20 | use parent '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 parent '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 parent '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 | |
| 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 | |
| 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"); |