xref: /openbsd-src/gnu/usr.bin/perl/t/mro/basic.t (revision 2b0358df1d88d06ef4139321dd05bd5e05d91eaf) 
1#!./perl
2
3use strict;
4use warnings;
5
6require q(./test.pl); plan(tests => 38);
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
23my @MFO_F_DFS = qw/MRO_F MRO_D MRO_A MRO_B MRO_C MRO_E/;
24my @MFO_F_C3 = qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/;
25is(mro::get_mro('MRO_F'), 'dfs');
26ok(eq_array(
27    mro::get_linear_isa('MRO_F'), \@MFO_F_DFS
28));
29
30ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS));
31ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3));
32eval{mro::get_linear_isa('MRO_F', 'C3')};
33like($@, qr/^Invalid mro name: 'C3'/);
34
35mro::set_mro('MRO_F', 'c3');
36is(mro::get_mro('MRO_F'), 'c3');
37ok(eq_array(
38    mro::get_linear_isa('MRO_F'), \@MFO_F_C3
39));
40
41ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS));
42ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3));
43eval{mro::get_linear_isa('MRO_F', 'C3')};
44like($@, qr/^Invalid mro name: 'C3'/);
45
46my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')};
47ok(eq_array(
48    \@isarev,
49    [qw/MRO_D MRO_E MRO_F/]
50));
51
52ok(!mro::is_universal('MRO_B'));
53
54@UNIVERSAL::ISA = qw/MRO_F/;
55ok(mro::is_universal('MRO_B'));
56
57@UNIVERSAL::ISA = ();
58ok(mro::is_universal('MRO_B'));
59
60# is_universal, get_mro, and get_linear_isa should
61# handle non-existant packages sanely
62ok(!mro::is_universal('Does_Not_Exist'));
63is(mro::get_mro('Also_Does_Not_Exist'), 'dfs');
64ok(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;
78is(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
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
221