Commit | Line | Data |
e1a479c5 |
1 | #!./perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
2e7640f0 |
6 | require q(./test.pl); plan(tests => 38); |
e1a479c5 |
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 | |
84dccb35 |
23 | my @MFO_F_DFS = qw/MRO_F MRO_D MRO_A MRO_B MRO_C MRO_E/; |
24 | my @MFO_F_C3 = qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/; |
e1a479c5 |
25 | is(mro::get_mro('MRO_F'), 'dfs'); |
c94dd5be |
26 | ok(eq_array( |
84dccb35 |
27 | mro::get_linear_isa('MRO_F'), \@MFO_F_DFS |
c94dd5be |
28 | )); |
84dccb35 |
29 | |
30 | ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS)); |
31 | ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3)); |
32 | eval{mro::get_linear_isa('MRO_F', 'C3')}; |
33 | like($@, qr/^Invalid mro name: 'C3'/); |
34 | |
e1a479c5 |
35 | mro::set_mro('MRO_F', 'c3'); |
36 | is(mro::get_mro('MRO_F'), 'c3'); |
c94dd5be |
37 | ok(eq_array( |
84dccb35 |
38 | mro::get_linear_isa('MRO_F'), \@MFO_F_C3 |
c94dd5be |
39 | )); |
e1a479c5 |
40 | |
84dccb35 |
41 | ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS)); |
42 | ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3)); |
43 | eval{mro::get_linear_isa('MRO_F', 'C3')}; |
44 | like($@, qr/^Invalid mro name: 'C3'/); |
45 | |
70cd14a1 |
46 | my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')}; |
c94dd5be |
47 | ok(eq_array( |
48 | \@isarev, |
e1a479c5 |
49 | [qw/MRO_D MRO_E MRO_F/] |
c94dd5be |
50 | )); |
e1a479c5 |
51 | |
52 | ok(!mro::is_universal('MRO_B')); |
53 | |
54 | @UNIVERSAL::ISA = qw/MRO_F/; |
55 | ok(mro::is_universal('MRO_B')); |
56 | |
57 | @UNIVERSAL::ISA = (); |
58 | ok(mro::is_universal('MRO_B')); |
70cd14a1 |
59 | |
60 | # is_universal, get_mro, and get_linear_isa should |
61 | # handle non-existant packages sanely |
62 | ok(!mro::is_universal('Does_Not_Exist')); |
63 | is(mro::get_mro('Also_Does_Not_Exist'), 'dfs'); |
64 | ok(eq_array( |
65 | mro::get_linear_isa('Does_Not_Exist_Three'), |
66 | [qw/Does_Not_Exist_Three/] |
67 | )); |
68 | |
69 | # Assigning @ISA via globref |
70 | { |
71 | package MRO_TestBase; |
72 | sub testfunc { return 123 } |
73 | package MRO_TestOtherBase; |
74 | sub testfunctwo { return 321 } |
75 | package MRO_M; our @ISA = qw/MRO_TestBase/; |
76 | } |
77 | *MRO_N::ISA = *MRO_M::ISA; |
78 | is(eval { MRO_N->testfunc() }, 123); |
79 | |
80 | # XXX TODO (when there's a way to backtrack through a glob's aliases) |
81 | # push(@MRO_M::ISA, 'MRO_TestOtherBase'); |
82 | # is(eval { MRO_N->testfunctwo() }, 321); |
9b439311 |
83 | |
84 | # Simple DESTROY Baseline |
85 | { |
86 | my $x = 0; |
87 | my $obj; |
88 | |
89 | { |
90 | package DESTROY_MRO_Baseline; |
91 | sub new { bless {} => shift } |
92 | sub DESTROY { $x++ } |
93 | |
94 | package DESTROY_MRO_Baseline_Child; |
95 | our @ISA = qw/DESTROY_MRO_Baseline/; |
96 | } |
97 | |
98 | $obj = DESTROY_MRO_Baseline->new(); |
99 | undef $obj; |
100 | is($x, 1); |
101 | |
102 | $obj = DESTROY_MRO_Baseline_Child->new(); |
103 | undef $obj; |
104 | is($x, 2); |
105 | } |
106 | |
107 | # Dynamic DESTROY |
108 | { |
109 | my $x = 0; |
110 | my $obj; |
111 | |
112 | { |
113 | package DESTROY_MRO_Dynamic; |
114 | sub new { bless {} => shift } |
115 | |
116 | package DESTROY_MRO_Dynamic_Child; |
117 | our @ISA = qw/DESTROY_MRO_Dynamic/; |
118 | } |
119 | |
120 | $obj = DESTROY_MRO_Dynamic->new(); |
121 | undef $obj; |
122 | is($x, 0); |
123 | |
124 | $obj = DESTROY_MRO_Dynamic_Child->new(); |
125 | undef $obj; |
126 | is($x, 0); |
127 | |
128 | no warnings 'once'; |
129 | *DESTROY_MRO_Dynamic::DESTROY = sub { $x++ }; |
130 | |
131 | $obj = DESTROY_MRO_Dynamic->new(); |
132 | undef $obj; |
133 | is($x, 1); |
134 | |
135 | $obj = DESTROY_MRO_Dynamic_Child->new(); |
136 | undef $obj; |
137 | is($x, 2); |
138 | } |
22717f83 |
139 | |
140 | # clearing @ISA in different ways |
5be5c7a6 |
141 | # some are destructive to the package, hence the new |
142 | # package name each time |
22717f83 |
143 | { |
144 | no warnings 'uninitialized'; |
145 | { |
146 | package ISACLEAR; |
147 | our @ISA = qw/XX YY ZZ/; |
148 | } |
149 | # baseline |
150 | ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX YY ZZ/])); |
151 | |
152 | # this looks dumb, but it preserves existing behavior for compatibility |
153 | # (undefined @ISA elements treated as "main") |
154 | $ISACLEAR::ISA[1] = undef; |
155 | ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX main ZZ/])); |
156 | |
5be5c7a6 |
157 | # undef the array itself |
22717f83 |
158 | undef @ISACLEAR::ISA; |
159 | ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR/])); |
915d8d75 |
160 | |
161 | # Now, clear more than one package's @ISA at once |
162 | { |
163 | package ISACLEAR1; |
164 | our @ISA = qw/WW XX/; |
165 | |
166 | package ISACLEAR2; |
167 | our @ISA = qw/YY ZZ/; |
168 | } |
169 | # baseline |
170 | ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1 WW XX/])); |
171 | ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2 YY ZZ/])); |
172 | (@ISACLEAR1::ISA, @ISACLEAR2::ISA) = (); |
173 | |
934dcd01 |
174 | ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1/])); |
915d8d75 |
175 | ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2/])); |
176 | } |
177 | |
178 | # Check that recursion bails out "cleanly" in a variety of cases |
179 | # (as opposed to say, bombing the interpreter or something) |
180 | { |
181 | my @recurse_codes = ( |
182 | '@MRO_R1::ISA = "MRO_R2"; @MRO_R2::ISA = "MRO_R1";', |
183 | '@MRO_R3::ISA = "MRO_R4"; push(@MRO_R4::ISA, "MRO_R3");', |
184 | '@MRO_R5::ISA = "MRO_R6"; @MRO_R6::ISA = qw/XX MRO_R5 YY/;', |
185 | '@MRO_R7::ISA = "MRO_R8"; push(@MRO_R8::ISA, qw/XX MRO_R7 YY/)', |
186 | ); |
187 | foreach my $code (@recurse_codes) { |
188 | eval $code; |
189 | ok($@ =~ /Recursive inheritance detected/); |
190 | } |
22717f83 |
191 | } |
915d8d75 |
192 | |
2e7640f0 |
193 | # Check that SUPER caches get invalidated correctly |
194 | { |
195 | { |
196 | package SUPERTEST; |
197 | sub new { bless {} => shift } |
198 | sub foo { $_[1]+1 } |
199 | |
200 | package SUPERTEST::MID; |
201 | our @ISA = 'SUPERTEST'; |
202 | |
203 | package SUPERTEST::KID; |
204 | our @ISA = 'SUPERTEST::MID'; |
205 | sub foo { my $s = shift; $s->SUPER::foo(@_) } |
206 | |
207 | package SUPERTEST::REBASE; |
208 | sub foo { $_[1]+3 } |
209 | } |
210 | |
211 | my $stk_obj = SUPERTEST::KID->new(); |
212 | is($stk_obj->foo(1), 2); |
213 | { no warnings 'redefine'; |
214 | *SUPERTEST::foo = sub { $_[1]+2 }; |
215 | } |
216 | is($stk_obj->foo(2), 4); |
217 | @SUPERTEST::MID::ISA = 'SUPERTEST::REBASE'; |
218 | is($stk_obj->foo(3), 6); |
219 | } |
220 | |