This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change 31977 introduced a bug (failing to set the return value of
[perl5.git] / t / mro / basic.t
1 #!./perl
2
3 use strict;
4 use warnings;
5
6 require q(./test.pl); plan(tests => 35);
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 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/;
25 is(mro::get_mro('MRO_F'), 'dfs');
26 ok(eq_array(
27     mro::get_linear_isa('MRO_F'), \@MFO_F_DFS
28 ));
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
35 mro::set_mro('MRO_F', 'c3');
36 is(mro::get_mro('MRO_F'), 'c3');
37 ok(eq_array(
38     mro::get_linear_isa('MRO_F'), \@MFO_F_C3
39 ));
40
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
46 my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')};
47 ok(eq_array(
48     \@isarev,
49     [qw/MRO_D MRO_E MRO_F/]
50 ));
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'));
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);
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 }
139
140 # clearing @ISA in different ways
141 #  some are destructive to the package, hence the new
142 #  package name each time
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
157     # undef the array itself
158     undef @ISACLEAR::ISA;
159     ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR/]));
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
174     ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1/]));
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     }
191 }
192