t/mro/basic.t

   1 #!./perl
   2
   3 use strict;
   4 use warnings;
   5
   6 require q(./test.pl); plan(tests => 18);
   7
   8 {
   9     package MRO_A;
  10     our @ISA = qw//;
  11     package MRO_B;
  12     our @ISA = qw//;
  13     package MRO_C;
  14     our @ISA = qw//;
  15     package MRO_D;
  16     our @ISA = qw/MRO_A MRO_B MRO_C/;
  17     package MRO_E;
  18     our @ISA = qw/MRO_A MRO_B MRO_C/;
  19     package MRO_F;
  20     our @ISA = qw/MRO_D MRO_E/;
  21 }
  22
  23 is(mro::get_mro('MRO_F'), 'dfs');
  24 ok(eq_array(
  25     mro::get_linear_isa('MRO_F'),
  26     [qw/MRO_F MRO_D MRO_A MRO_B MRO_C MRO_E/]
  27 ));
  28 mro::set_mro('MRO_F', 'c3');
  29 is(mro::get_mro('MRO_F'), 'c3');
  30 ok(eq_array(
  31     mro::get_linear_isa('MRO_F'),
  32     [qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/]
  33 ));
  34
  35 my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')};
  36 ok(eq_array(
  37     \@isarev,
  38     [qw/MRO_D MRO_E MRO_F/]
  39 ));
  40
  41 ok(!mro::is_universal('MRO_B'));
  42
  43 @UNIVERSAL::ISA = qw/MRO_F/;
  44 ok(mro::is_universal('MRO_B'));
  45
  46 @UNIVERSAL::ISA = ();
  47 ok(mro::is_universal('MRO_B'));
  48
  49 # is_universal, get_mro, and get_linear_isa should
  50 # handle non-existant packages sanely
  51 ok(!mro::is_universal('Does_Not_Exist'));
  52 is(mro::get_mro('Also_Does_Not_Exist'), 'dfs');
  53 ok(eq_array(
  54     mro::get_linear_isa('Does_Not_Exist_Three'),
  55     [qw/Does_Not_Exist_Three/]
  56 ));
  57
  58 # Assigning @ISA via globref
  59 {
  60     package MRO_TestBase;
  61     sub testfunc { return 123 }
  62     package MRO_TestOtherBase;
  63     sub testfunctwo { return 321 }
  64     package MRO_M; our @ISA = qw/MRO_TestBase/;
  65 }
  66 *MRO_N::ISA = *MRO_M::ISA;
  67 is(eval { MRO_N->testfunc() }, 123);
  68
  69 # XXX TODO (when there's a way to backtrack through a glob's aliases)
  70 # push(@MRO_M::ISA, 'MRO_TestOtherBase');
  71 # is(eval { MRO_N->testfunctwo() }, 321);
  72
  73 # Simple DESTROY Baseline
  74 {
  75     my $x = 0;
  76     my $obj;
  77
  78     {
  79         package DESTROY_MRO_Baseline;
  80         sub new { bless {} => shift }
  81         sub DESTROY { $x++ }
  82
  83         package DESTROY_MRO_Baseline_Child;
  84         our @ISA = qw/DESTROY_MRO_Baseline/;
  85     }
  86
  87     $obj = DESTROY_MRO_Baseline->new();
  88     undef $obj;
  89     is($x, 1);
  90
  91     $obj = DESTROY_MRO_Baseline_Child->new();
  92     undef $obj;
  93     is($x, 2);
  94 }
  95
  96 # Dynamic DESTROY
  97 {
  98     my $x = 0;
  99     my $obj;
 100
 101     {
 102         package DESTROY_MRO_Dynamic;
 103         sub new { bless {} => shift }
 104
 105         package DESTROY_MRO_Dynamic_Child;
 106         our @ISA = qw/DESTROY_MRO_Dynamic/;
 107     }
 108
 109     $obj = DESTROY_MRO_Dynamic->new();
 110     undef $obj;
 111     is($x, 0);
 112
 113     $obj = DESTROY_MRO_Dynamic_Child->new();
 114     undef $obj;
 115     is($x, 0);
 116
 117     no warnings 'once';
 118     *DESTROY_MRO_Dynamic::DESTROY = sub { $x++ };
 119
 120     $obj = DESTROY_MRO_Dynamic->new();
 121     undef $obj;
 122     is($x, 1);
 123
 124     $obj = DESTROY_MRO_Dynamic_Child->new();
 125     undef $obj;
 126     is($x, 2);
 127 }