lib/version/t/02derived.t

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