lib/base/t/base.t

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