Commit | Line | Data |
e1a479c5 |
1 | #!./perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
0fa56319 |
6 | require q(./test.pl); plan(tests => 21); |
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 | |
23 | is(mro::get_mro('MRO_F'), 'dfs'); |
c94dd5be |
24 | ok(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 |
28 | mro::set_mro('MRO_F', 'c3'); |
29 | is(mro::get_mro('MRO_F'), 'c3'); |
c94dd5be |
30 | ok(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 |
35 | my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')}; |
c94dd5be |
36 | ok(eq_array( |
37 | \@isarev, |
e1a479c5 |
38 | [qw/MRO_D MRO_E MRO_F/] |
c94dd5be |
39 | )); |
e1a479c5 |
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')); |
70cd14a1 |
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); |
9b439311 |
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 |
128 | |
129 | # clearing @ISA in different ways |
5be5c7a6 |
130 | # some are destructive to the package, hence the new |
131 | # package name each time |
22717f83 |
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 |
147 | undef @ISACLEAR::ISA; |
148 | ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR/])); |
149 | } |