1#!./perl -w 2 3# 4# test method calls and autoloading. 5# 6 7BEGIN { 8 chdir 't' if -d 't'; 9 require "./test.pl"; 10 set_up_inc( qw(. ../lib lib ../dist/base/lib) ); 11} 12 13use strict; 14no warnings 'once'; 15 16plan(tests => 163); 17 18{ 19 # RT #126042 &{1==1} * &{1==1} would crash 20 # There are two issues here. Method lookup yields a fake method for 21 # ->import or ->unimport if there's no actual method, for historical 22 # reasons so that "use" doesn't barf if there's no import method. 23 # The first bug, the one which caused the crash, is that the fake 24 # method was broken in scalar context, messing up the stack. We test 25 # for that on its own. 26 foreach my $meth (qw(import unimport)) { 27 is join(",", map { $_ // "u" } "a", "b", "Unknown"->$meth, "c", "d"), "a,b,c,d", "Unknown->$meth in list context"; 28 is join(",", map { $_ // "u" } "a", "b", scalar("Unknown"->$meth), "c", "d"), "a,b,u,c,d", "Unknown->$meth in scalar context"; 29 } 30 # The second issue is that the fake method wasn't actually a CV or 31 # anything referencing a CV, but was &PL_sv_yes being used as a magic 32 # placeholder. That's inconsistent with &PL_sv_yes being a string, 33 # which we'd expect to serve as a symbolic CV ref. This test must 34 # come before AUTOLOAD gets set up below. 35 foreach my $one (1, !!1) { 36 my @res = eval { no strict "refs"; &$one() }; 37 like $@, qr/\AUndefined subroutine \&main::1 called at /; 38 @res = eval { no strict "refs"; local *1 = sub { 123 }; &$one() }; 39 is $@, ""; 40 is "@res", "123"; 41 @res = eval { &$one() }; 42 like $@, qr/\ACan't use string \("1"\) as a subroutine ref while "strict refs" in use at /; 43 } 44} 45 46@A::ISA = 'BB'; 47@BB::ISA = 'C'; 48 49sub C::d {"C::d"} 50sub D::d {"D::d"} 51 52# First, some basic checks of method-calling syntax: 53my $obj = bless [], "Pack"; 54sub Pack::method { shift; join(",", "method", @_) } 55my $mname = "method"; 56 57is(Pack->method("a","b","c"), "method,a,b,c"); 58is(Pack->$mname("a","b","c"), "method,a,b,c"); 59is(method Pack ("a","b","c"), "method,a,b,c"); 60is((method Pack "a","b","c"), "method,a,b,c"); 61 62is(Pack->method(), "method"); 63is(Pack->$mname(), "method"); 64is(method Pack (), "method"); 65is(Pack->method, "method"); 66is(Pack->$mname, "method"); 67is(method Pack, "method"); 68 69is($obj->method("a","b","c"), "method,a,b,c"); 70is($obj->$mname("a","b","c"), "method,a,b,c"); 71is((method $obj ("a","b","c")), "method,a,b,c"); 72is((method $obj "a","b","c"), "method,a,b,c"); 73 74is($obj->method(0), "method,0"); 75is($obj->method(1), "method,1"); 76 77is($obj->method(), "method"); 78is($obj->$mname(), "method"); 79is((method $obj ()), "method"); 80is($obj->method, "method"); 81is($obj->$mname, "method"); 82is(method $obj, "method"); 83 84is( A->d, "C::d"); # Update hash table; 85 86*BB::d = \&D::d; # Import now. 87is(A->d, "D::d"); # Update hash table; 88 89{ 90 local @A::ISA = qw(C); # Update hash table with split() assignment 91 is(A->d, "C::d"); 92 $#A::ISA = -1; 93 is(eval { A->d } || "fail", "fail"); 94} 95is(A->d, "D::d"); 96 97{ 98 local *BB::d; 99 eval 'sub BB::d {"BB::d1"}'; # Import now. 100 is(A->d, "BB::d1"); # Update hash table; 101 undef &BB::d; 102 is((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); 103} 104 105is(A->d, "D::d"); # Back to previous state 106 107eval 'no warnings "redefine"; sub BB::d {"BB::d2"}'; # Import now. 108is(A->d, "BB::d2"); # Update hash table; 109 110# What follows is hardly guarantied to work, since the names in scripts 111# are already linked to "pruned" globs. Say, 'undef &BB::d' if it were 112# after 'delete $BB::{d}; sub BB::d {}' would reach an old subroutine. 113 114undef &BB::d; 115delete $BB::{d}; 116is(A->d, "C::d"); 117 118eval 'sub BB::d {"BB::d2.5"}'; 119A->d; # Update hash table; 120my $glob = \delete $BB::{d}; # non-void context; hang on to the glob 121is(A->d, "C::d"); # Update hash table; 122 123eval 'sub BB::d {"BB::d3"}'; # Import now. 124is(A->d, "BB::d3"); # Update hash table; 125 126delete $BB::{d}; 127*dummy::dummy = sub {}; # Mark as updated 128is(A->d, "C::d"); 129 130eval 'sub BB::d {"BB::d4"}'; # Import now. 131is(A->d, "BB::d4"); # Update hash table; 132 133delete $BB::{d}; # Should work without any help too 134is(A->d, "C::d"); 135 136{ 137 local *C::d; 138 is(eval { A->d } || "nope", "nope"); 139} 140is(A->d, "C::d"); 141 142*A::x = *A::d; 143A->d; 144is(eval { A->x } || "nope", "nope", 'cache should not follow synonyms'); 145 146my $counter; 147 148eval <<'EOF'; 149sub C::e; 150BEGIN { *BB::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg 151sub Y::f; 152$counter = 0; 153 154@X::ISA = 'Y'; 155@Y::ISA = 'BB'; 156 157sub BB::AUTOLOAD { 158 my $c = ++$counter; 159 my $method = $BB::AUTOLOAD; 160 my $msg = "B: In $method, $c"; 161 eval "sub $method { \$msg }"; 162 goto &$method; 163} 164sub C::AUTOLOAD { 165 my $c = ++$counter; 166 my $method = $C::AUTOLOAD; 167 my $msg = "C: In $method, $c"; 168 eval "sub $method { \$msg }"; 169 goto &$method; 170} 171EOF 172 173is(A->e(), "C: In C::e, 1"); # We get a correct autoload 174is(A->e(), "C: In C::e, 1"); # Which sticks 175 176is(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top 177is(A->ee(), "B: In A::ee, 2"); # Which sticks 178 179is(Y->f(), "B: In Y::f, 3"); # We vivify a correct method 180is(Y->f(), "B: In Y::f, 3"); # Which sticks 181 182# This test is not intended to be reasonable. It is here just to let you 183# know that you broke some old construction. Feel free to rewrite the test 184# if your patch breaks it. 185 186{ 187no warnings 'redefine'; 188*BB::AUTOLOAD = sub { 189 use warnings; 190 my $c = ++$counter; 191 my $method = $::AUTOLOAD; 192 no strict 'refs'; 193 *$::AUTOLOAD = sub { "new B: In $method, $c" }; 194 goto &$::AUTOLOAD; 195}; 196} 197 198is(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload 199is(A->eee(), "new B: In A::eee, 4"); # Which sticks 200 201# test that failed subroutine calls don't affect method calls 202{ 203 package A1; 204 sub foo { "foo" } 205 package A2; 206 @A2::ISA = 'A1'; 207 package main; 208 is(A2->foo(), "foo"); 209 is(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); 210 is(A2->foo(), "foo"); 211} 212 213## This test was totally misguided. It passed before only because the 214## code to determine if a package was loaded used to look for the hash 215## %Foo::Bar instead of the package Foo::Bar:: -- and Config.pm just 216## happens to export %Config. 217# { 218# is(do { use Config; eval 'Config->foo()'; 219# $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); 220# is(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; 221# $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); 222# } 223 224# test error messages if method loading fails 225my $e; 226 227eval '$e = bless {}, "E::A"; E::A->foo()'; 228like ($@, qr/^\QCan't locate object method "foo" via package "E::A" at/); 229eval '$e = bless {}, "E::B"; $e->foo()'; 230like ($@, qr/^\QCan't locate object method "foo" via package "E::B" at/); 231eval 'E::C->foo()'; 232like ($@, qr/^\QCan't locate object method "foo" via package "E::C" (perhaps /); 233 234eval 'UNIVERSAL->E::D::foo()'; 235like ($@, qr/^\QCan't locate object method "foo" via package "E::D" (perhaps /); 236eval 'my $e = bless {}, "UNIVERSAL"; $e->E::E::foo()'; 237like ($@, qr/^\QCan't locate object method "foo" via package "E::E" (perhaps /); 238 239$e = bless {}, "E::F"; # force package to exist 240eval 'UNIVERSAL->E::F::foo()'; 241like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/); 242eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()'; 243like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/); 244 245# SUPER:: pseudoclass 246@Saab::ISA = "Souper"; 247sub Souper::method { @_ } 248@OtherSaab::ISA = "OtherSouper"; 249sub OtherSouper::method { "Isidore Ropen, Draft Manager" } 250{ 251 my $o = bless [], "Saab"; 252 package Saab; 253 my @ret = $o->SUPER::method('whatever'); 254 ::is $ret[0], $o, 'object passed to SUPER::method'; 255 ::is $ret[1], 'whatever', 'argument passed to SUPER::method'; 256 { 257 no warnings qw(syntax deprecated); 258 @ret = $o->SUPER'method('whatever'); 259 } 260 ::is $ret[0], $o, "object passed to SUPER'method"; 261 ::is $ret[1], 'whatever', "argument passed to SUPER'method"; 262 @ret = Saab->SUPER::method; 263 ::is $ret[0], 'Saab', "package name passed to SUPER::method"; 264 @ret = OtherSaab->SUPER::method; 265 ::is $ret[0], 'OtherSaab', 266 "->SUPER::method uses current package, not invocant"; 267} 268() = *SUPER::; 269{ 270 local our @ISA = "Souper"; 271 is eval { (main->SUPER::method)[0] }, 'main', 272 'Mentioning *SUPER:: does not stop ->SUPER from working in main'; 273} 274{ 275 BEGIN { 276 *Mover:: = *Mover2::; 277 *Mover2:: = *foo; 278 } 279 package Mover; 280 no strict; 281 # Not our(@ISA), because the bug we are testing for interacts with an 282 # our() bug that cancels this bug out. 283 @ISA = 'door'; 284 sub door::dohtem { 'dohtem' } 285 ::is eval { Mover->SUPER::dohtem; }, 'dohtem', 286 'SUPER inside moved package'; 287 undef *door::dohtem; 288 *door::dohtem = sub { 'method' }; 289 ::is eval { Mover->SUPER::dohtem; }, 'method', 290 'SUPER inside moved package respects method changes'; 291} 292 293package foo120694 { 294 BEGIN { our @ISA = qw(bar120694) } 295 296 sub AUTOLOAD { 297 my $self = shift; 298 local our $recursive = $recursive; 299 return "recursive" if $recursive++; 300 return if our $AUTOLOAD eq 'DESTROY'; 301 $AUTOLOAD = "SUPER:" . substr $AUTOLOAD, rindex($AUTOLOAD, ':'); 302 return $self->$AUTOLOAD(@_); 303 } 304} 305package bar120694 { 306 sub AUTOLOAD { 307 return "xyzzy"; 308 } 309} 310is bless( [] => "foo120694" )->plugh, 'xyzzy', 311 '->SUPER::method autoloading uses parent of current pkg'; 312 313 314# failed method call or UNIVERSAL::can() should not autovivify packages 315is( $::{"Foo::"} || "none", "none"); # sanity check 1 316is( $::{"Foo::"} || "none", "none"); # sanity check 2 317 318is( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" ); 319is( $::{"Foo::"} || "none", "none"); # still missing? 320 321is( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" ); 322is( $::{"Foo::"} || "none", "none"); # still missing? 323 324is( Foo->can("boogie") ? "yes":"no", "no" ); 325is( $::{"Foo::"} || "none", "none"); # still missing? 326 327is( eval 'Foo->boogie(); 1' ? "yes":"no", "no" ); 328is( $::{"Foo::"} || "none", "none"); # still missing? 329 330is(do { eval 'Foo->boogie()'; 331 $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1); 332 333eval 'sub Foo::boogie { "yes, sir!" }'; 334is( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now 335is( Foo->boogie(), "yes, sir!"); 336 337# TODO: universal.t should test NoSuchPackage->isa()/can() 338 339# This is actually testing parsing of indirect objects and undefined subs 340# print foo("bar") where foo does not exist is not an indirect object. 341# print foo "bar" where foo does not exist is an indirect object. 342eval 'sub AUTOLOAD { "ok ", shift, "\n"; }'; 343ok(1); 344 345# Bug ID 20010902.002 (#7609) 346is( 347 eval q[ 348 my $x = 'x'; # Lexical or package variable, 5.6.1 panics. 349 sub Foo::x : lvalue { $x } 350 Foo->$x = 'ok'; 351 ] || $@, 'ok' 352); 353 354# An autoloaded, inherited DESTROY may be invoked differently than normal 355# methods, and has been known to give rise to spurious warnings 356# eg <200203121600.QAA11064@gizmo.fdgroup.co.uk> 357 358{ 359 use warnings; 360 my $w = ''; 361 local $SIG{__WARN__} = sub { $w = $_[0] }; 362 363 sub AutoDest::Base::AUTOLOAD {} 364 @AutoDest::ISA = qw(AutoDest::Base); 365 { my $x = bless {}, 'AutoDest'; } 366 $w =~ s/\n//g; 367 is($w, ''); 368} 369 370# [ID 20020305.025 (#8788)] PACKAGE::SUPER doesn't work anymore 371 372package main; 373our @X; 374package Amajor; 375sub test { 376 push @main::X, 'Amajor', @_; 377} 378package Bminor; 379use base qw(Amajor); 380package main; 381sub Bminor::test { 382 $_[0]->Bminor::SUPER::test('x', 'y'); 383 push @main::X, 'Bminor', @_; 384} 385Bminor->test('y', 'z'); 386is("@X", "Amajor Bminor x y Bminor Bminor y z"); 387 388package main; 389for my $meth (['Bar', 'Foo::Bar'], 390 ['SUPER::Bar', 'main::SUPER::Bar'], 391 ['Xyz::SUPER::Bar', 'Xyz::SUPER::Bar']) 392{ 393 fresh_perl_is(<<EOT, 394package UNIVERSAL; sub AUTOLOAD { my \$c = shift; print "\$c \$AUTOLOAD\\n" } 395sub DESTROY {} # prevent AUTOLOAD being called on DESTROY 396package Xyz; 397package main; Foo->$meth->[0](); 398EOT 399 "Foo $meth->[1]", 400 { switches => [ '-w' ] }, 401 "check if UNIVERSAL::AUTOLOAD works", 402 ); 403} 404 405# Test for #71952: crash when looking for a nonexistent destructor 406# Regression introduced by fbb3ee5af3d4 407{ 408 fresh_perl_is(<<'EOT', 409sub M::DESTROY; bless {}, "M" ; print "survived\n"; 410EOT 411 "survived", 412 {}, 413 "no crash with a declared but missing DESTROY method" 414 ); 415} 416 417# Test for calling a method on a packag name return by a magic variable 418sub TIESCALAR{bless[]} 419sub FETCH{"main"} 420my $kalled; 421sub bolgy { ++$kalled; } 422tie my $a, ""; 423$a->bolgy; 424is $kalled, 1, 'calling a class method via a magic variable'; 425 426{ 427 package NulTest; 428 sub method { 1 } 429 430 package main; 431 eval { 432 NulTest->${ \"method\0Whoops" }; 433 }; 434 like $@, qr/Can't locate object method "method\\0Whoops" via package "NulTest" at/, 435 "method lookup is nul-clean"; 436 437 *NulTest::AUTOLOAD = sub { our $AUTOLOAD; return $AUTOLOAD }; 438 439 like(NulTest->${ \"nul\0test" }, qr/nul\0test/, "AUTOLOAD is nul-clean"); 440} 441 442 443{ 444 fresh_perl_is( 445 q! sub T::DESTROY { $x = $_[0]; } bless [], "T";!, 446 "DESTROY created new reference to dead object 'T' during global destruction.", 447 {}, 448 "DESTROY creating a new reference to the object generates a warning." 449 ); 450} 451 452# [perl #43663] 453{ 454 $::{"Just"} = \1; 455 sub Just::a_japh { return "$_[0] another Perl hacker," } 456 is eval { "Just"->a_japh }, "Just another Perl hacker,", 457 'constants do not interfere with class methods'; 458} 459 460# [perl #109264] 461{ 462 no strict 'vars'; 463 sub bliggles { 1 } 464 sub lbiggles :lvalue { index "foo", "f" } 465 ok eval { main->bliggles(my($foo,$bar)) }, 466 'foo->bar(my($foo,$bar)) is not called in lvalue context'; 467 ok eval { main->bliggles(our($foo,$bar)) }, 468 'foo->bar(our($foo,$bar)) is not called in lvalue context'; 469 ok eval { main->bliggles(local($foo,$bar)) }, 470 'foo->bar(local($foo,$bar)) is not called in lvalue context'; 471 ok eval { () = main->lbiggles(my($foo,$bar)); 1 }, 472 'foo->lv(my($foo,$bar)) is not called in lvalue context'; 473 ok eval { () = main->lbiggles(our($foo,$bar)); 1 }, 474 'foo->lv(our($foo,$bar)) is not called in lvalue context'; 475 ok eval { () = main->lbiggles(local($foo,$bar)); 1 }, 476 'foo->lv(local($foo,$bar)) is not called in lvalue context'; 477} 478 479{ 480 # AUTOLOAD and DESTROY can be declared without a leading sub, 481 # like BEGIN and friends. 482 package NoSub; 483 484 eval 'AUTOLOAD { our $AUTOLOAD; return $AUTOLOAD }'; 485 ::ok( !$@, "AUTOLOAD without a leading sub is legal" ); 486 487 eval "DESTROY { ::pass( q!DESTROY without a leading sub is legal and gets called! ) }"; 488 { 489 ::ok( NoSub->can("AUTOLOAD"), "...and sets up an AUTOLOAD normally" ); 490 ::is( eval { NoSub->bluh }, "NoSub::bluh", "...which works as expected" ); 491 } 492 { bless {}, "NoSub"; } 493} 494 495{ 496 # [perl #124387] 497 my $autoloaded; 498 package AutoloadDestroy; 499 sub AUTOLOAD { $autoloaded = 1 } 500 package main; 501 bless {}, "AutoloadDestroy"; 502 ok($autoloaded, "AUTOLOAD called for DESTROY"); 503 504 # 127494 - AUTOLOAD for DESTROY was called without setting $AUTOLOAD 505 my %methods; 506 package AutoloadDestroy2; 507 sub AUTOLOAD { 508 our $AUTOLOAD; 509 (my $method = $AUTOLOAD) =~ s/.*:://; 510 ++$methods{$method}; 511 } 512 package main; 513 # this cached AUTOLOAD as the DESTROY method 514 bless {}, "AutoloadDestroy2"; 515 %methods = (); 516 my $o = bless {}, "AutoloadDestroy2"; 517 # this sets $AUTOLOAD to "AutoloadDestroy2::foo" 518 $o->foo; 519 # this would call AUTOLOAD without setting $AUTOLOAD 520 undef $o; 521 ok($methods{DESTROY}, "\$AUTOLOAD set correctly for DESTROY"); 522} 523 524eval { () = 3; new {} }; 525like $@, 526 qr/^Can't call method "new" without a package or object reference/, 527 'Err msg from new{} when stack contains a number'; 528eval { () = "foo"; new {} }; 529like $@, 530 qr/^Can't call method "new" without a package or object reference/, 531 'Err msg from new{} when stack contains a word'; 532eval { () = undef; new {} }; 533like $@, 534 qr/^Can't call method "new" without a package or object reference/, 535 'Err msg from new{} when stack contains undef'; 536 537package egakacp { 538 our @ISA = 'ASI'; 539 sub ASI::m { shift; "@_" }; 540 my @a = (bless([]), 'arg'); 541 my $r = SUPER::m{@a}; 542 ::is $r, 'arg', 'method{@array}'; 543 $r = SUPER::m{}@a; 544 ::is $r, 'arg', 'method{}@array'; 545 $r = SUPER::m{@a}"b"; 546 ::is $r, 'arg b', 'method{@array}$more_args'; 547} 548 549# [perl #114924] SUPER->method 550@SUPER::ISA = "SUPPER"; 551sub SUPPER::foo { "supper" } 552is "SUPER"->foo, 'supper', 'SUPER->method'; 553 554sub flomp { "flimp" } 555sub main::::flomp { "flump" } 556is "::"->flomp, 'flump', 'method call on ::'; 557is "::main"->flomp, 'flimp', 'method call on ::main'; 558eval { ""->flomp }; 559like $@, 560 qr/^Can't call method "flomp" without a package or object reference/, 561 'method call on empty string'; 562is "3foo"->CORE::uc, '3FOO', '"3foo"->CORE::uc'; 563{ no strict; @{"3foo::ISA"} = "CORE"; } 564is "3foo"->uc, '3FOO', '"3foo"->uc (autobox style!)'; 565 566# *foo vs (\*foo) 567sub myclass::squeak { 'eek' } 568eval { *myclass->squeak }; 569like $@, 570 qr/^Can't call method "squeak" without a package or object reference/, 571 'method call on typeglob ignores package'; 572eval { (\*myclass)->squeak }; 573like $@, 574 qr/^Can't call method "squeak" on unblessed reference/, 575 'method call on \*typeglob'; 576*stdout2 = *STDOUT; # stdout2 now stringifies as *main::STDOUT 577 sub IO::Handle::self { $_[0] } 578# This used to stringify the glob: 579is *stdout2->self, (\*stdout2)->self, 580 '*glob->method is equiv to (\*glob)->method'; 581sub { $_[0] = *STDOUT; is $_[0]->self, \$::h{k}, '$pvlv_glob->method' } 582 ->($::h{k}); 583 584# Test that PL_stashcache doesn't change the resolution behaviour for file 585# handles and package names. 586SKIP: { 587 skip_if_miniperl('file handles as methods requires loading IO::File', 26); 588 require Fcntl; 589 590 foreach (qw (Count::DATA Count Colour::H1 Color::H1 C3::H1)) { 591 eval qq{ 592 package $_; 593 594 sub getline { 595 return "method in $_"; 596 } 597 598 1; 599 } or die $@; 600 } 601 602 BEGIN { 603 *The::Count:: = \*Count::; 604 } 605 606 is(Count::DATA->getline(), 'method in Count::DATA', 607 'initial resolution is a method'); 608 is(The::Count::DATA->getline(), 'method in Count::DATA', 609 'initial resolution is a method in aliased classes'); 610 611 require Count; 612 613 is(Count::DATA->getline(), "one! ha ha ha\n", 'file handles take priority'); 614 is(The::Count::DATA->getline(), "two! ha ha ha\n", 615 'file handles take priority in aliased classes'); 616 617 eval q{close Count::DATA} or die $!; 618 619 { 620 no warnings 'io'; 621 is(Count::DATA->getline(), undef, 622 "closing a file handle doesn't change object resolution"); 623 is(The::Count::DATA->getline(), undef, 624 "closing a file handle doesn't change object resolution in aliased classes"); 625} 626 627 undef *Count::DATA; 628 is(Count::DATA->getline(), 'method in Count::DATA', 629 'undefining the typeglob does change object resolution'); 630 is(The::Count::DATA->getline(), 'method in Count::DATA', 631 'undefining the typeglob does change object resolution in aliased classes'); 632 633 is(Count->getline(), 'method in Count', 634 'initial resolution is a method'); 635 is(The::Count->getline(), 'method in Count', 636 'initial resolution is a method in aliased classes'); 637 638 eval q{ 639 open Count, '<', $INC{'Count.pm'} 640 or die "Can't open $INC{'Count.pm'}: $!"; 6411; 642 } or die $@; 643 644 is(Count->getline(), "# zero! ha ha ha\n", 'file handles take priority'); 645 is(The::Count->getline(), 'method in Count', 'but not in an aliased class'); 646 647 eval q{close Count} or die $!; 648 649 { 650 no warnings 'io'; 651 is(Count->getline(), undef, 652 "closing a file handle doesn't change object resolution"); 653 } 654 655 undef *Count; 656 is(Count->getline(), 'method in Count', 657 'undefining the typeglob does change object resolution'); 658 659 open Colour::H1, 'op/method.t' or die $!; 660 while (<Colour::H1>) { 661 last if /^__END__/; 662 } 663 open CLOSED, 'TEST' or die $!; 664 close CLOSED or die $!; 665 666 my $fh_start = tell Colour::H1; 667 my $data_start = tell DATA; 668 is(Colour::H1->getline(), <DATA>, 'read from a file'); 669 is(Color::H1->getline(), 'method in Color::H1', 670 'initial resolution is a method'); 671 672 *Color::H1 = *Colour::H1{IO}; 673 674 is(Colour::H1->getline(), <DATA>, 'read from a file'); 675 is(Color::H1->getline(), <DATA>, 676 'file handles take priority after io-to-typeglob assignment'); 677 678 *Color::H1 = *CLOSED{IO}; 679 { 680 no warnings 'io'; 681 is(Color::H1->getline(), undef, 682 "assigning a closed a file handle doesn't change object resolution"); 683 } 684 685 undef *Color::H1; 686 is(Color::H1->getline(), 'method in Color::H1', 687 'undefining the typeglob does change object resolution'); 688 689 *Color::H1 = *Colour::H1; 690 691 is(Color::H1->getline(), <DATA>, 692 'file handles take priority after typeglob-to-typeglob assignment'); 693 694 seek Colour::H1, $fh_start, Fcntl::SEEK_SET() or die $!; 695 seek DATA, $data_start, Fcntl::SEEK_SET() or die $!; 696 697 is(Colour::H1->getline(), <DATA>, 'read from a file'); 698 is(C3::H1->getline(), 'method in C3::H1', 'initial resolution is a method'); 699 700 *Copy:: = \*C3::; 701 *C3:: = \*Colour::; 702 703 is(Colour::H1->getline(), <DATA>, 'read from a file'); 704 is(C3::H1->getline(), <DATA>, 705 'file handles take priority after stash aliasing'); 706 707 *C3:: = \*Copy::; 708 709 is(C3::H1->getline(), 'method in C3::H1', 710 'restoring the stash returns to a method'); 711} 712 713# RT #123619 constant class name should be read-only 714 715{ 716 sub RT123619::f { chop $_[0] } 717 eval { 'RT123619'->f(); }; 718 like ($@, qr/Modification of a read-only value attempted/, 'RT #123619'); 719} 720 721{ 722 fresh_perl_is(<<'PROG', <<'EXPECT', {}, "don't negative cache NOUNIVERSAL lookups"); 723use v5.36; 724 725my $foo; 726 727BEGIN { 728 $foo = bless {}, 'Foo'; 729 $foo->isa('Foo') and say "->isa works!"; 730 } 731 732# bump PL_sub_generation 733local *Foo::DESTROY = sub {}; 734undef &Foo::DESTROY; 735local *Foo::DESTROY = sub {}; 736 737$foo isa 'Foo' and say " and isa works!"; 738$foo->isa('Foo') and say "->isa works!"; 739 740PROG 741->isa works! 742 and isa works! 743->isa works! 744EXPECT 745} 746 747# RT#130496: assertion failure when looking for a method of undefined name 748# on an unblessed reference 749fresh_perl_is('eval { {}->$x }; print $@;', 750 "Can't call method \"\" on unblessed reference at - line 1.", 751 {}, 752 "no crash with undef method name on unblessed ref"); 753 754__END__ 755#FF9900 756#F78C08 757#FFA500 758#FF4D00 759#FC5100 760#FF5D00 761