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