This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Document SvSHARED_HASH.
[perl5.git] / t / mro / basic.t
CommitLineData
e1a479c5
BB
1#!./perl
2
3use strict;
4use warnings;
5
0fa56319 6require q(./test.pl); plan(tests => 21);
e1a479c5
BB
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
23is(mro::get_mro('MRO_F'), 'dfs');
c94dd5be
RGS
24ok(eq_array(
25 mro::get_linear_isa('MRO_F'),
e1a479c5 26 [qw/MRO_F MRO_D MRO_A MRO_B MRO_C MRO_E/]
c94dd5be 27));
e1a479c5
BB
28mro::set_mro('MRO_F', 'c3');
29is(mro::get_mro('MRO_F'), 'c3');
c94dd5be
RGS
30ok(eq_array(
31 mro::get_linear_isa('MRO_F'),
e1a479c5 32 [qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/]
c94dd5be 33));
e1a479c5 34
70cd14a1 35my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')};
c94dd5be
RGS
36ok(eq_array(
37 \@isarev,
e1a479c5 38 [qw/MRO_D MRO_E MRO_F/]
c94dd5be 39));
e1a479c5
BB
40
41ok(!mro::is_universal('MRO_B'));
42
43@UNIVERSAL::ISA = qw/MRO_F/;
44ok(mro::is_universal('MRO_B'));
45
46@UNIVERSAL::ISA = ();
47ok(mro::is_universal('MRO_B'));
70cd14a1
CB
48
49# is_universal, get_mro, and get_linear_isa should
50# handle non-existant packages sanely
51ok(!mro::is_universal('Does_Not_Exist'));
52is(mro::get_mro('Also_Does_Not_Exist'), 'dfs');
53ok(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;
67is(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);
9b439311
BB
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}
22717f83
BB
128
129# clearing @ISA in different ways
5be5c7a6
BB
130# some are destructive to the package, hence the new
131# package name each time
22717f83
BB
132{
133 no warnings 'uninitialized';
134 {
135 package ISACLEAR;
136 our @ISA = qw/XX YY ZZ/;
137 }
138 # baseline
139 ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX YY ZZ/]));
140
141 # this looks dumb, but it preserves existing behavior for compatibility
142 # (undefined @ISA elements treated as "main")
143 $ISACLEAR::ISA[1] = undef;
144 ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX main ZZ/]));
145
5be5c7a6 146 # undef the array itself
22717f83
BB
147 undef @ISACLEAR::ISA;
148 ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR/]));
149}