1#!./perl 2 3use strict; 4use warnings; 5 6BEGIN { require q(./test.pl); } plan(tests => 52); 7 8require mro; 9 10{ 11 package MRO_A; 12 our @ISA = qw//; 13 package MRO_B; 14 our @ISA = qw//; 15 package MRO_C; 16 our @ISA = qw//; 17 package MRO_D; 18 our @ISA = qw/MRO_A MRO_B MRO_C/; 19 package MRO_E; 20 our @ISA = qw/MRO_A MRO_B MRO_C/; 21 package MRO_F; 22 our @ISA = qw/MRO_D MRO_E/; 23} 24 25my @MFO_F_DFS = qw/MRO_F MRO_D MRO_A MRO_B MRO_C MRO_E/; 26my @MFO_F_C3 = qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/; 27is(mro::get_mro('MRO_F'), 'dfs'); 28ok(eq_array( 29 mro::get_linear_isa('MRO_F'), \@MFO_F_DFS 30)); 31 32ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS)); 33ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3)); 34eval{mro::get_linear_isa('MRO_F', 'C3')}; 35like($@, qr/^Invalid mro name: 'C3'/); 36 37mro::set_mro('MRO_F', 'c3'); 38is(mro::get_mro('MRO_F'), 'c3'); 39ok(eq_array( 40 mro::get_linear_isa('MRO_F'), \@MFO_F_C3 41)); 42 43ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS)); 44ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3)); 45eval{mro::get_linear_isa('MRO_F', 'C3')}; 46like($@, qr/^Invalid mro name: 'C3'/); 47 48my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')}; 49ok(eq_array( 50 \@isarev, 51 [qw/MRO_D MRO_E MRO_F/] 52)); 53 54ok(!mro::is_universal('MRO_B')); 55 56@UNIVERSAL::ISA = qw/MRO_F/; 57ok(mro::is_universal('MRO_B')); 58 59@UNIVERSAL::ISA = (); 60ok(!mro::is_universal('MRO_B')); 61 62# is_universal, get_mro, and get_linear_isa should 63# handle non-existent packages sanely 64ok(!mro::is_universal('Does_Not_Exist')); 65is(mro::get_mro('Also_Does_Not_Exist'), 'dfs'); 66ok(eq_array( 67 mro::get_linear_isa('Does_Not_Exist_Three'), 68 [qw/Does_Not_Exist_Three/] 69)); 70 71# Assigning @ISA via globref 72{ 73 package MRO_TestBase; 74 sub testfunc { return 123 } 75 package MRO_TestOtherBase; 76 sub testfunctwo { return 321 } 77 package MRO_M; our @ISA = qw/MRO_TestBase/; 78} 79*MRO_N::ISA = *MRO_M::ISA; 80is(eval { MRO_N->testfunc() }, 123); 81 82# XXX TODO (when there's a way to backtrack through a glob's aliases) 83# push(@MRO_M::ISA, 'MRO_TestOtherBase'); 84# is(eval { MRO_N->testfunctwo() }, 321); 85 86# Simple DESTROY Baseline 87{ 88 my $x = 0; 89 my $obj; 90 91 { 92 package DESTROY_MRO_Baseline; 93 sub new { bless {} => shift } 94 sub DESTROY { $x++ } 95 96 package DESTROY_MRO_Baseline_Child; 97 our @ISA = qw/DESTROY_MRO_Baseline/; 98 } 99 100 $obj = DESTROY_MRO_Baseline->new(); 101 undef $obj; 102 is($x, 1); 103 104 $obj = DESTROY_MRO_Baseline_Child->new(); 105 undef $obj; 106 is($x, 2); 107} 108 109# Dynamic DESTROY 110{ 111 my $x = 0; 112 my $obj; 113 114 { 115 package DESTROY_MRO_Dynamic; 116 sub new { bless {} => shift } 117 118 package DESTROY_MRO_Dynamic_Child; 119 our @ISA = qw/DESTROY_MRO_Dynamic/; 120 } 121 122 $obj = DESTROY_MRO_Dynamic->new(); 123 undef $obj; 124 is($x, 0); 125 126 $obj = DESTROY_MRO_Dynamic_Child->new(); 127 undef $obj; 128 is($x, 0); 129 130 no warnings 'once'; 131 *DESTROY_MRO_Dynamic::DESTROY = sub { $x++ }; 132 133 $obj = DESTROY_MRO_Dynamic->new(); 134 undef $obj; 135 is($x, 1); 136 137 $obj = DESTROY_MRO_Dynamic_Child->new(); 138 undef $obj; 139 is($x, 2); 140} 141 142# clearing @ISA in different ways 143# some are destructive to the package, hence the new 144# package name each time 145{ 146 no warnings 'uninitialized'; 147 { 148 package ISACLEAR; 149 our @ISA = qw/XX YY ZZ/; 150 } 151 # baseline 152 ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX YY ZZ/])); 153 154 # this looks dumb, but it preserves existing behavior for compatibility 155 # (undefined @ISA elements treated as "main") 156 $ISACLEAR::ISA[1] = undef; 157 ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX main ZZ/])); 158 159 # undef the array itself 160 undef @ISACLEAR::ISA; 161 ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR/])); 162 163 # Now, clear more than one package's @ISA at once 164 { 165 package ISACLEAR1; 166 our @ISA = qw/WW XX/; 167 168 package ISACLEAR2; 169 our @ISA = qw/YY ZZ/; 170 } 171 # baseline 172 ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1 WW XX/])); 173 ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2 YY ZZ/])); 174 (@ISACLEAR1::ISA, @ISACLEAR2::ISA) = (); 175 176 ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1/])); 177 ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2/])); 178 179 # [perl #49564] This is a pretty obscure way of clearing @ISA but 180 # it tests a regression that affects XS code calling av_clear too. 181 { 182 package ISACLEAR3; 183 our @ISA = qw/WW XX/; 184 } 185 ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3 WW XX/])); 186 { 187 package ISACLEAR3; 188 reset 'I'; 189 } 190 ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3/])); 191} 192 193# Check that recursion bails out "cleanly" in a variety of cases 194# (as opposed to say, bombing the interpreter or something) 195{ 196 my @recurse_codes = ( 197 '@MRO_R1::ISA = "MRO_R2"; @MRO_R2::ISA = "MRO_R1";', 198 '@MRO_R3::ISA = "MRO_R4"; push(@MRO_R4::ISA, "MRO_R3");', 199 '@MRO_R5::ISA = "MRO_R6"; @MRO_R6::ISA = qw/XX MRO_R5 YY/;', 200 '@MRO_R7::ISA = "MRO_R8"; push(@MRO_R8::ISA, qw/XX MRO_R7 YY/)', 201 ); 202 foreach my $code (@recurse_codes) { 203 eval $code; 204 ok($@ =~ /Recursive inheritance detected/); 205 } 206} 207 208# Check that SUPER caches get invalidated correctly 209{ 210 { 211 package SUPERTEST; 212 sub new { bless {} => shift } 213 sub foo { $_[1]+1 } 214 215 package SUPERTEST::MID; 216 our @ISA = 'SUPERTEST'; 217 218 package SUPERTEST::KID; 219 our @ISA = 'SUPERTEST::MID'; 220 sub foo { my $s = shift; $s->SUPER::foo(@_) } 221 222 package SUPERTEST::REBASE; 223 sub foo { $_[1]+3 } 224 } 225 226 my $stk_obj = SUPERTEST::KID->new(); 227 is($stk_obj->foo(1), 2); 228 { no warnings 'redefine'; 229 *SUPERTEST::foo = sub { $_[1]+2 }; 230 } 231 is($stk_obj->foo(2), 4); 232 @SUPERTEST::MID::ISA = 'SUPERTEST::REBASE'; 233 is($stk_obj->foo(3), 6); 234} 235 236{ 237 { 238 # assigning @ISA via arrayref to globref RT 60220 239 package P1; 240 sub new { bless {}, shift } 241 242 package P2; 243 } 244 *{P2::ISA} = [ 'P1' ]; 245 my $foo = P2->new; 246 ok(!eval { $foo->bark }, "no bark method"); 247 no warnings 'once'; # otherwise it'll bark about P1::bark used only once 248 *{P1::bark} = sub { "[bark]" }; 249 is(scalar eval { $foo->bark }, "[bark]", "can bark now"); 250} 251 252{ 253 # assigning @ISA via arrayref then modifying it RT 72866 254 { 255 package Q1; 256 sub foo { } 257 258 package Q2; 259 sub bar { } 260 261 package Q3; 262 } 263 push @Q3::ISA, "Q1"; 264 can_ok("Q3", "foo"); 265 *Q3::ISA = []; 266 push @Q3::ISA, "Q1"; 267 can_ok("Q3", "foo"); 268 *Q3::ISA = []; 269 push @Q3::ISA, "Q2"; 270 can_ok("Q3", "bar"); 271 ok(!Q3->can("foo"), "can't call foo method any longer"); 272} 273 274{ 275 # test mro::method_changed_in 276 my $count = mro::get_pkg_gen("MRO_A"); 277 mro::method_changed_in("MRO_A"); 278 my $count_new = mro::get_pkg_gen("MRO_A"); 279 280 is($count_new, $count + 1); 281} 282 283{ 284 # test if we can call mro::invalidate_all_method_caches; 285 eval { 286 mro::invalidate_all_method_caches(); 287 }; 288 is($@, ""); 289} 290 291{ 292 # @main::ISA 293 no warnings 'once'; 294 @main::ISA = 'parent'; 295 my $output = ''; 296 *parent::do = sub { $output .= 'parent' }; 297 *parent2::do = sub { $output .= 'parent2' }; 298 main->do; 299 @main::ISA = 'parent2'; 300 main->do; 301 is $output, 'parentparent2', '@main::ISA is magical'; 302} 303 304{ 305 # Undefining *ISA, then modifying @ISA 306 # This broke Class::Trait. See [perl #79024]. 307 {package Class::Trait::Base} 308 no strict 'refs'; 309 undef *{"Extra::TSpouse::ISA"}; 310 'Extra::TSpouse'->isa('Class::Trait::Base'); # cache the mro 311 unshift @{"Extra::TSpouse::ISA"}, 'Class::Trait::Base'; 312 ok 'Extra::TSpouse'->isa('Class::Trait::Base'), 313 'a isa b after undef *a::ISA and @a::ISA modification'; 314} 315 316{ 317 # Deleting $package::{ISA} 318 # Broken in 5.10.0; fixed in 5.13.7 319 @Blength::ISA = 'Bladd'; 320 delete $Blength::{ISA}; 321 ok !Blength->isa("Bladd"), 'delete $package::{ISA}'; 322} 323 324{ 325 # Undefining stashes 326 @Thrext::ISA = "Thwit"; 327 @Thwit::ISA = "Sile"; 328 undef %Thwit::; 329 ok !Thrext->isa('Sile'), 'undef %package:: updates subclasses'; 330} 331