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