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 => 162); 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 @ret = $o->SUPER'method('whatever'); 257 ::is $ret[0], $o, "object passed to SUPER'method"; 258 ::is $ret[1], 'whatever', "argument passed to SUPER'method"; 259 @ret = Saab->SUPER::method; 260 ::is $ret[0], 'Saab', "package name passed to SUPER::method"; 261 @ret = OtherSaab->SUPER::method; 262 ::is $ret[0], 'OtherSaab', 263 "->SUPER::method uses current package, not invocant"; 264} 265() = *SUPER::; 266{ 267 local our @ISA = "Souper"; 268 is eval { (main->SUPER::method)[0] }, 'main', 269 'Mentioning *SUPER:: does not stop ->SUPER from working in main'; 270} 271{ 272 BEGIN { 273 *Mover:: = *Mover2::; 274 *Mover2:: = *foo; 275 } 276 package Mover; 277 no strict; 278 # Not our(@ISA), because the bug we are testing for interacts with an 279 # our() bug that cancels this bug out. 280 @ISA = 'door'; 281 sub door::dohtem { 'dohtem' } 282 ::is eval { Mover->SUPER::dohtem; }, 'dohtem', 283 'SUPER inside moved package'; 284 undef *door::dohtem; 285 *door::dohtem = sub { 'method' }; 286 ::is eval { Mover->SUPER::dohtem; }, 'method', 287 'SUPER inside moved package respects method changes'; 288} 289 290package foo120694 { 291 BEGIN { our @ISA = qw(bar120694) } 292 293 sub AUTOLOAD { 294 my $self = shift; 295 local our $recursive = $recursive; 296 return "recursive" if $recursive++; 297 return if our $AUTOLOAD eq 'DESTROY'; 298 $AUTOLOAD = "SUPER:" . substr $AUTOLOAD, rindex($AUTOLOAD, ':'); 299 return $self->$AUTOLOAD(@_); 300 } 301} 302package bar120694 { 303 sub AUTOLOAD { 304 return "xyzzy"; 305 } 306} 307is bless( [] => "foo120694" )->plugh, 'xyzzy', 308 '->SUPER::method autoloading uses parent of current pkg'; 309 310 311# failed method call or UNIVERSAL::can() should not autovivify packages 312is( $::{"Foo::"} || "none", "none"); # sanity check 1 313is( $::{"Foo::"} || "none", "none"); # sanity check 2 314 315is( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" ); 316is( $::{"Foo::"} || "none", "none"); # still missing? 317 318is( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" ); 319is( $::{"Foo::"} || "none", "none"); # still missing? 320 321is( Foo->can("boogie") ? "yes":"no", "no" ); 322is( $::{"Foo::"} || "none", "none"); # still missing? 323 324is( eval 'Foo->boogie(); 1' ? "yes":"no", "no" ); 325is( $::{"Foo::"} || "none", "none"); # still missing? 326 327is(do { eval 'Foo->boogie()'; 328 $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1); 329 330eval 'sub Foo::boogie { "yes, sir!" }'; 331is( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now 332is( Foo->boogie(), "yes, sir!"); 333 334# TODO: universal.t should test NoSuchPackage->isa()/can() 335 336# This is actually testing parsing of indirect objects and undefined subs 337# print foo("bar") where foo does not exist is not an indirect object. 338# print foo "bar" where foo does not exist is an indirect object. 339eval 'sub AUTOLOAD { "ok ", shift, "\n"; }'; 340ok(1); 341 342# Bug ID 20010902.002 (#7609) 343is( 344 eval q[ 345 my $x = 'x'; # Lexical or package variable, 5.6.1 panics. 346 sub Foo::x : lvalue { $x } 347 Foo->$x = 'ok'; 348 ] || $@, 'ok' 349); 350 351# An autoloaded, inherited DESTROY may be invoked differently than normal 352# methods, and has been known to give rise to spurious warnings 353# eg <200203121600.QAA11064@gizmo.fdgroup.co.uk> 354 355{ 356 use warnings; 357 my $w = ''; 358 local $SIG{__WARN__} = sub { $w = $_[0] }; 359 360 sub AutoDest::Base::AUTOLOAD {} 361 @AutoDest::ISA = qw(AutoDest::Base); 362 { my $x = bless {}, 'AutoDest'; } 363 $w =~ s/\n//g; 364 is($w, ''); 365} 366 367# [ID 20020305.025 (#8788)] PACKAGE::SUPER doesn't work anymore 368 369package main; 370our @X; 371package Amajor; 372sub test { 373 push @main::X, 'Amajor', @_; 374} 375package Bminor; 376use base qw(Amajor); 377package main; 378sub Bminor::test { 379 $_[0]->Bminor::SUPER::test('x', 'y'); 380 push @main::X, 'Bminor', @_; 381} 382Bminor->test('y', 'z'); 383is("@X", "Amajor Bminor x y Bminor Bminor y z"); 384 385package main; 386for my $meth (['Bar', 'Foo::Bar'], 387 ['SUPER::Bar', 'main::SUPER::Bar'], 388 ['Xyz::SUPER::Bar', 'Xyz::SUPER::Bar']) 389{ 390 fresh_perl_is(<<EOT, 391package UNIVERSAL; sub AUTOLOAD { my \$c = shift; print "\$c \$AUTOLOAD\\n" } 392sub DESTROY {} # prevent AUTOLOAD being called on DESTROY 393package Xyz; 394package main; Foo->$meth->[0](); 395EOT 396 "Foo $meth->[1]", 397 { switches => [ '-w' ] }, 398 "check if UNIVERSAL::AUTOLOAD works", 399 ); 400} 401 402# Test for #71952: crash when looking for a nonexistent destructor 403# Regression introduced by fbb3ee5af3d4 404{ 405 fresh_perl_is(<<'EOT', 406sub M::DESTROY; bless {}, "M" ; print "survived\n"; 407EOT 408 "survived", 409 {}, 410 "no crash with a declared but missing DESTROY method" 411 ); 412} 413 414# Test for calling a method on a packag name return by a magic variable 415sub TIESCALAR{bless[]} 416sub FETCH{"main"} 417my $kalled; 418sub bolgy { ++$kalled; } 419tie my $a, ""; 420$a->bolgy; 421is $kalled, 1, 'calling a class method via a magic variable'; 422 423{ 424 package NulTest; 425 sub method { 1 } 426 427 package main; 428 eval { 429 NulTest->${ \"method\0Whoops" }; 430 }; 431 like $@, qr/Can't locate object method "method\0Whoops" via package "NulTest" at/, 432 "method lookup is nul-clean"; 433 434 *NulTest::AUTOLOAD = sub { our $AUTOLOAD; return $AUTOLOAD }; 435 436 like(NulTest->${ \"nul\0test" }, qr/nul\0test/, "AUTOLOAD is nul-clean"); 437} 438 439 440{ 441 fresh_perl_is( 442 q! sub T::DESTROY { $x = $_[0]; } bless [], "T";!, 443 "DESTROY created new reference to dead object 'T' during global destruction.", 444 {}, 445 "DESTROY creating a new reference to the object generates a warning." 446 ); 447} 448 449# [perl #43663] 450{ 451 $::{"Just"} = \1; 452 sub Just::a_japh { return "$_[0] another Perl hacker," } 453 is eval { "Just"->a_japh }, "Just another Perl hacker,", 454 'constants do not interfere with class methods'; 455} 456 457# [perl #109264] 458{ 459 no strict 'vars'; 460 sub bliggles { 1 } 461 sub lbiggles :lvalue { index "foo", "f" } 462 ok eval { main->bliggles(my($foo,$bar)) }, 463 'foo->bar(my($foo,$bar)) is not called in lvalue context'; 464 ok eval { main->bliggles(our($foo,$bar)) }, 465 'foo->bar(our($foo,$bar)) is not called in lvalue context'; 466 ok eval { main->bliggles(local($foo,$bar)) }, 467 'foo->bar(local($foo,$bar)) is not called in lvalue context'; 468 ok eval { () = main->lbiggles(my($foo,$bar)); 1 }, 469 'foo->lv(my($foo,$bar)) is not called in lvalue context'; 470 ok eval { () = main->lbiggles(our($foo,$bar)); 1 }, 471 'foo->lv(our($foo,$bar)) is not called in lvalue context'; 472 ok eval { () = main->lbiggles(local($foo,$bar)); 1 }, 473 'foo->lv(local($foo,$bar)) is not called in lvalue context'; 474} 475 476{ 477 # AUTOLOAD and DESTROY can be declared without a leading sub, 478 # like BEGIN and friends. 479 package NoSub; 480 481 eval 'AUTOLOAD { our $AUTOLOAD; return $AUTOLOAD }'; 482 ::ok( !$@, "AUTOLOAD without a leading sub is legal" ); 483 484 eval "DESTROY { ::pass( q!DESTROY without a leading sub is legal and gets called! ) }"; 485 { 486 ::ok( NoSub->can("AUTOLOAD"), "...and sets up an AUTOLOAD normally" ); 487 ::is( eval { NoSub->bluh }, "NoSub::bluh", "...which works as expected" ); 488 } 489 { bless {}, "NoSub"; } 490} 491 492{ 493 # [perl #124387] 494 my $autoloaded; 495 package AutoloadDestroy; 496 sub AUTOLOAD { $autoloaded = 1 } 497 package main; 498 bless {}, "AutoloadDestroy"; 499 ok($autoloaded, "AUTOLOAD called for DESTROY"); 500 501 # 127494 - AUTOLOAD for DESTROY was called without setting $AUTOLOAD 502 my %methods; 503 package AutoloadDestroy2; 504 sub AUTOLOAD { 505 our $AUTOLOAD; 506 (my $method = $AUTOLOAD) =~ s/.*:://; 507 ++$methods{$method}; 508 } 509 package main; 510 # this cached AUTOLOAD as the DESTROY method 511 bless {}, "AutoloadDestroy2"; 512 %methods = (); 513 my $o = bless {}, "AutoloadDestroy2"; 514 # this sets $AUTOLOAD to "AutoloadDestroy2::foo" 515 $o->foo; 516 # this would call AUTOLOAD without setting $AUTOLOAD 517 undef $o; 518 ok($methods{DESTROY}, "\$AUTOLOAD set correctly for DESTROY"); 519} 520 521eval { () = 3; new {} }; 522like $@, 523 qr/^Can't call method "new" without a package or object reference/, 524 'Err msg from new{} when stack contains a number'; 525eval { () = "foo"; new {} }; 526like $@, 527 qr/^Can't call method "new" without a package or object reference/, 528 'Err msg from new{} when stack contains a word'; 529eval { () = undef; new {} }; 530like $@, 531 qr/^Can't call method "new" without a package or object reference/, 532 'Err msg from new{} when stack contains undef'; 533 534package egakacp { 535 our @ISA = 'ASI'; 536 sub ASI::m { shift; "@_" }; 537 my @a = (bless([]), 'arg'); 538 my $r = SUPER::m{@a}; 539 ::is $r, 'arg', 'method{@array}'; 540 $r = SUPER::m{}@a; 541 ::is $r, 'arg', 'method{}@array'; 542 $r = SUPER::m{@a}"b"; 543 ::is $r, 'arg b', 'method{@array}$more_args'; 544} 545 546# [perl #114924] SUPER->method 547@SUPER::ISA = "SUPPER"; 548sub SUPPER::foo { "supper" } 549is "SUPER"->foo, 'supper', 'SUPER->method'; 550 551sub flomp { "flimp" } 552sub main::::flomp { "flump" } 553is "::"->flomp, 'flump', 'method call on ::'; 554is "::main"->flomp, 'flimp', 'method call on ::main'; 555eval { ""->flomp }; 556like $@, 557 qr/^Can't call method "flomp" without a package or object reference/, 558 'method call on empty string'; 559is "3foo"->CORE::uc, '3FOO', '"3foo"->CORE::uc'; 560{ no strict; @{"3foo::ISA"} = "CORE"; } 561is "3foo"->uc, '3FOO', '"3foo"->uc (autobox style!)'; 562 563# *foo vs (\*foo) 564sub myclass::squeak { 'eek' } 565eval { *myclass->squeak }; 566like $@, 567 qr/^Can't call method "squeak" without a package or object reference/, 568 'method call on typeglob ignores package'; 569eval { (\*myclass)->squeak }; 570like $@, 571 qr/^Can't call method "squeak" on unblessed reference/, 572 'method call on \*typeglob'; 573*stdout2 = *STDOUT; # stdout2 now stringifies as *main::STDOUT 574 sub IO::Handle::self { $_[0] } 575# This used to stringify the glob: 576is *stdout2->self, (\*stdout2)->self, 577 '*glob->method is equiv to (\*glob)->method'; 578sub { $_[0] = *STDOUT; is $_[0]->self, \$::h{k}, '$pvlv_glob->method' } 579 ->($::h{k}); 580 581# Test that PL_stashcache doesn't change the resolution behaviour for file 582# handles and package names. 583SKIP: { 584 skip_if_miniperl('file handles as methods requires loading IO::File', 26); 585 require Fcntl; 586 587 foreach (qw (Count::DATA Count Colour::H1 Color::H1 C3::H1)) { 588 eval qq{ 589 package $_; 590 591 sub getline { 592 return "method in $_"; 593 } 594 595 1; 596 } or die $@; 597 } 598 599 BEGIN { 600 *The::Count:: = \*Count::; 601 } 602 603 is(Count::DATA->getline(), 'method in Count::DATA', 604 'initial resolution is a method'); 605 is(The::Count::DATA->getline(), 'method in Count::DATA', 606 'initial resolution is a method in aliased classes'); 607 608 require Count; 609 610 is(Count::DATA->getline(), "one! ha ha ha\n", 'file handles take priority'); 611 is(The::Count::DATA->getline(), "two! ha ha ha\n", 612 'file handles take priority in aliased classes'); 613 614 eval q{close Count::DATA} or die $!; 615 616 { 617 no warnings 'io'; 618 is(Count::DATA->getline(), undef, 619 "closing a file handle doesn't change object resolution"); 620 is(The::Count::DATA->getline(), undef, 621 "closing a file handle doesn't change object resolution in aliased classes"); 622} 623 624 undef *Count::DATA; 625 is(Count::DATA->getline(), 'method in Count::DATA', 626 'undefining the typeglob does change object resolution'); 627 is(The::Count::DATA->getline(), 'method in Count::DATA', 628 'undefining the typeglob does change object resolution in aliased classes'); 629 630 is(Count->getline(), 'method in Count', 631 'initial resolution is a method'); 632 is(The::Count->getline(), 'method in Count', 633 'initial resolution is a method in aliased classes'); 634 635 eval q{ 636 open Count, '<', $INC{'Count.pm'} 637 or die "Can't open $INC{'Count.pm'}: $!"; 6381; 639 } or die $@; 640 641 is(Count->getline(), "# zero! ha ha ha\n", 'file handles take priority'); 642 is(The::Count->getline(), 'method in Count', 'but not in an aliased class'); 643 644 eval q{close Count} or die $!; 645 646 { 647 no warnings 'io'; 648 is(Count->getline(), undef, 649 "closing a file handle doesn't change object resolution"); 650 } 651 652 undef *Count; 653 is(Count->getline(), 'method in Count', 654 'undefining the typeglob does change object resolution'); 655 656 open Colour::H1, 'op/method.t' or die $!; 657 while (<Colour::H1>) { 658 last if /^__END__/; 659 } 660 open CLOSED, 'TEST' or die $!; 661 close CLOSED or die $!; 662 663 my $fh_start = tell Colour::H1; 664 my $data_start = tell DATA; 665 is(Colour::H1->getline(), <DATA>, 'read from a file'); 666 is(Color::H1->getline(), 'method in Color::H1', 667 'initial resolution is a method'); 668 669 *Color::H1 = *Colour::H1{IO}; 670 671 is(Colour::H1->getline(), <DATA>, 'read from a file'); 672 is(Color::H1->getline(), <DATA>, 673 'file handles take priority after io-to-typeglob assignment'); 674 675 *Color::H1 = *CLOSED{IO}; 676 { 677 no warnings 'io'; 678 is(Color::H1->getline(), undef, 679 "assigning a closed a file handle doesn't change object resolution"); 680 } 681 682 undef *Color::H1; 683 is(Color::H1->getline(), 'method in Color::H1', 684 'undefining the typeglob does change object resolution'); 685 686 *Color::H1 = *Colour::H1; 687 688 is(Color::H1->getline(), <DATA>, 689 'file handles take priority after typeglob-to-typeglob assignment'); 690 691 seek Colour::H1, $fh_start, Fcntl::SEEK_SET() or die $!; 692 seek DATA, $data_start, Fcntl::SEEK_SET() or die $!; 693 694 is(Colour::H1->getline(), <DATA>, 'read from a file'); 695 is(C3::H1->getline(), 'method in C3::H1', 'initial resolution is a method'); 696 697 *Copy:: = \*C3::; 698 *C3:: = \*Colour::; 699 700 is(Colour::H1->getline(), <DATA>, 'read from a file'); 701 is(C3::H1->getline(), <DATA>, 702 'file handles take priority after stash aliasing'); 703 704 *C3:: = \*Copy::; 705 706 is(C3::H1->getline(), 'method in C3::H1', 707 'restoring the stash returns to a method'); 708} 709 710# RT #123619 constant class name should be read-only 711 712{ 713 sub RT123619::f { chop $_[0] } 714 eval { 'RT123619'->f(); }; 715 like ($@, qr/Modification of a read-only value attempted/, 'RT #123619'); 716} 717 718# RT#130496: assertion failure when looking for a method of undefined name 719# on an unblessed reference 720fresh_perl_is('eval { {}->$x }; print $@;', 721 "Can't call method \"\" on unblessed reference at - line 1.", 722 {}, 723 "no crash with undef method name on unblessed ref"); 724 725__END__ 726#FF9900 727#F78C08 728#FFA500 729#FF4D00 730#FC5100 731#FF5D00 732