dist/base/t/base.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Test::More tests => 11;
   5
   6 use_ok('base');
   7
   8
   9 package No::Version;
  10
  11 use vars qw($Foo);
  12 sub VERSION { 42 }
  13
  14 package Test::Version;
  15
  16 use base qw(No::Version);
  17 ::ok( $No::Version::VERSION =~ /set by base\.pm/,          '$VERSION bug' );
  18
  19 # Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION
  20 package Has::Version;
  21
  22 BEGIN { $Has::Version::VERSION = '42' };
  23
  24 package Test::Version2;
  25
  26 use base qw(Has::Version);
  27 ::is( $Has::Version::VERSION, 42 );
  28
  29 package main;
  30
  31 my $eval1 = q{
  32   {
  33     package Eval1;
  34     {
  35       package Eval2;
  36       use base 'Eval1';
  37       $Eval2::VERSION = "1.02";
  38     }
  39     $Eval1::VERSION = "1.01";
  40   }
  41 };
  42
  43 eval $eval1;
  44 is( $@, '' );
  45
  46 is( $Eval1::VERSION, 1.01 );
  47
  48 is( $Eval2::VERSION, 1.02 );
  49
  50
  51 eval q{use base 'reallyReAlLyNotexists'};
  52 like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty\./,
  53                                           'base with empty package');
  54
  55 eval q{use base 'reallyReAlLyNotexists'};
  56 like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty\./,
  57                                           '  still empty on 2nd load');
  58 {
  59     my $warning;
  60     local $SIG{__WARN__} = sub { $warning = shift };
  61     eval q{package HomoGenous; use base 'HomoGenous';};
  62     like($warning, qr/^Class 'HomoGenous' tried to inherit from itself/,
  63                                           '  self-inheriting');
  64 }
  65
  66 {
  67     BEGIN { $Has::Version_0::VERSION = 0 }
  68
  69     package Test::Version3;
  70
  71     use base qw(Has::Version_0);
  72     ::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' );
  73 }
  74
  75
  76 {
  77     package Schlozhauer;
  78     use constant FIELDS => 6;
  79
  80     package Basilisco;
  81     eval q{ use base 'Schlozhauer' };
  82     ::is( $@, '', 'Can coexist with a FIELDS constant' );
  83 }