4 # test method calls and autoloading.
9 @INC = qw(. ../lib lib ../dist/base/lib);
24 # First, some basic checks of method-calling syntax:
25 my $obj = bless [], "Pack";
26 sub Pack::method { shift; join(",", "method", @_) }
29 is(Pack->method("a","b","c"), "method,a,b,c");
30 is(Pack->$mname("a","b","c"), "method,a,b,c");
31 is(method Pack ("a","b","c"), "method,a,b,c");
32 is((method Pack "a","b","c"), "method,a,b,c");
34 is(Pack->method(), "method");
35 is(Pack->$mname(), "method");
36 is(method Pack (), "method");
37 is(Pack->method, "method");
38 is(Pack->$mname, "method");
39 is(method Pack, "method");
41 is($obj->method("a","b","c"), "method,a,b,c");
42 is($obj->$mname("a","b","c"), "method,a,b,c");
43 is((method $obj ("a","b","c")), "method,a,b,c");
44 is((method $obj "a","b","c"), "method,a,b,c");
46 is($obj->method(0), "method,0");
47 is($obj->method(1), "method,1");
49 is($obj->method(), "method");
50 is($obj->$mname(), "method");
51 is((method $obj ()), "method");
52 is($obj->method, "method");
53 is($obj->$mname, "method");
54 is(method $obj, "method");
56 is( A->d, "C::d"); # Update hash table;
58 *B::d = \&D::d; # Import now.
59 is(A->d, "D::d"); # Update hash table;
62 local @A::ISA = qw(C); # Update hash table with split() assignment
65 is(eval { A->d } || "fail", "fail");
71 eval 'sub B::d {"B::d1"}'; # Import now.
72 is(A->d, "B::d1"); # Update hash table;
74 is((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1);
77 is(A->d, "D::d"); # Back to previous state
79 eval 'no warnings "redefine"; sub B::d {"B::d2"}'; # Import now.
80 is(A->d, "B::d2"); # Update hash table;
82 # What follows is hardly guarantied to work, since the names in scripts
83 # are already linked to "pruned" globs. Say, 'undef &B::d' if it were
84 # after 'delete $B::{d}; sub B::d {}' would reach an old subroutine.
90 eval 'sub B::d {"B::d2.5"}';
91 A->d; # Update hash table;
92 my $glob = \delete $B::{d}; # non-void context; hang on to the glob
93 is(A->d, "C::d"); # Update hash table;
95 eval 'sub B::d {"B::d3"}'; # Import now.
96 is(A->d, "B::d3"); # Update hash table;
99 *dummy::dummy = sub {}; # Mark as updated
102 eval 'sub B::d {"B::d4"}'; # Import now.
103 is(A->d, "B::d4"); # Update hash table;
105 delete $B::{d}; # Should work without any help too
110 is(eval { A->d } || "nope", "nope");
116 is(eval { A->x } || "nope", "nope", 'cache should not follow synonyms');
122 BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg
131 my $method = $B::AUTOLOAD;
132 my $msg = "B: In $method, $c";
133 eval "sub $method { \$msg }";
138 my $method = $C::AUTOLOAD;
139 my $msg = "C: In $method, $c";
140 eval "sub $method { \$msg }";
145 is(A->e(), "C: In C::e, 1"); # We get a correct autoload
146 is(A->e(), "C: In C::e, 1"); # Which sticks
148 is(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top
149 is(A->ee(), "B: In A::ee, 2"); # Which sticks
151 is(Y->f(), "B: In Y::f, 3"); # We vivify a correct method
152 is(Y->f(), "B: In Y::f, 3"); # Which sticks
154 # This test is not intended to be reasonable. It is here just to let you
155 # know that you broke some old construction. Feel free to rewrite the test
156 # if your patch breaks it.
159 no warnings 'redefine';
163 my $method = $::AUTOLOAD;
165 *$::AUTOLOAD = sub { "new B: In $method, $c" };
170 is(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload
171 is(A->eee(), "new B: In A::eee, 4"); # Which sticks
173 # test that failed subroutine calls don't affect method calls
180 is(A2->foo(), "foo");
181 is(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1);
182 is(A2->foo(), "foo");
185 ## This test was totally misguided. It passed before only because the
186 ## code to determine if a package was loaded used to look for the hash
187 ## %Foo::Bar instead of the package Foo::Bar:: -- and Config.pm just
188 ## happens to export %Config.
190 # is(do { use Config; eval 'Config->foo()';
191 # $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
192 # is(do { use Config; eval '$d = bless {}, "Config"; $d->foo()';
193 # $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
196 # test error messages if method loading fails
199 eval '$e = bless {}, "E::A"; E::A->foo()';
200 like ($@, qr/^\QCan't locate object method "foo" via package "E::A" at/);
201 eval '$e = bless {}, "E::B"; $e->foo()';
202 like ($@, qr/^\QCan't locate object method "foo" via package "E::B" at/);
204 like ($@, qr/^\QCan't locate object method "foo" via package "E::C" (perhaps /);
206 eval 'UNIVERSAL->E::D::foo()';
207 like ($@, qr/^\QCan't locate object method "foo" via package "E::D" (perhaps /);
208 eval 'my $e = bless {}, "UNIVERSAL"; $e->E::E::foo()';
209 like ($@, qr/^\QCan't locate object method "foo" via package "E::E" (perhaps /);
211 $e = bless {}, "E::F"; # force package to exist
212 eval 'UNIVERSAL->E::F::foo()';
213 like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/);
214 eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()';
215 like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/);
217 # SUPER:: pseudoclass
218 @Saab::ISA = "Souper";
219 sub Souper::method { @_ }
220 @OtherSaab::ISA = "OtherSouper";
221 sub OtherSouper::method { "Isidore Ropen, Draft Manager" }
223 my $o = bless [], "Saab";
225 my @ret = $o->SUPER::method('whatever');
226 ::is $ret[0], $o, 'object passed to SUPER::method';
227 ::is $ret[1], 'whatever', 'argument passed to SUPER::method';
228 @ret = $o->SUPER'method('whatever');
229 ::is $ret[0], $o, "object passed to SUPER'method";
230 ::is $ret[1], 'whatever', "argument passed to SUPER'method";
231 @ret = Saab->SUPER::method;
232 ::is $ret[0], 'Saab', "package name passed to SUPER::method";
233 @ret = OtherSaab->SUPER::method;
234 ::is $ret[0], 'OtherSaab',
235 "->SUPER::method uses current package, not invocant";
239 local our @ISA = "Souper";
240 is eval { (main->SUPER::method)[0] }, 'main',
241 'Mentioning *SUPER:: does not stop ->SUPER from working in main';
245 *Mover:: = *Mover2::;
250 # Not our(@ISA), because the bug we are testing for interacts with an
251 # our() bug that cancels this bug out.
253 sub door::dohtem { 'dohtem' }
254 ::is eval { Mover->SUPER::dohtem; }, 'dohtem',
255 'SUPER inside moved package';
257 *door::dohtem = sub { 'method' };
258 ::is eval { Mover->SUPER::dohtem; }, 'method',
259 'SUPER inside moved package respects method changes';
263 BEGIN { our @ISA = qw(bar120694) }
267 local our $recursive = $recursive;
268 return "recursive" if $recursive++;
269 return if our $AUTOLOAD eq 'DESTROY';
270 $AUTOLOAD = "SUPER:" . substr $AUTOLOAD, rindex($AUTOLOAD, ':');
271 return $self->$AUTOLOAD(@_);
279 is bless( [] => "foo120694" )->plugh, 'xyzzy',
280 '->SUPER::method autoloading uses parent of current pkg';
283 # failed method call or UNIVERSAL::can() should not autovivify packages
284 is( $::{"Foo::"} || "none", "none"); # sanity check 1
285 is( $::{"Foo::"} || "none", "none"); # sanity check 2
287 is( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" );
288 is( $::{"Foo::"} || "none", "none"); # still missing?
290 is( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" );
291 is( $::{"Foo::"} || "none", "none"); # still missing?
293 is( Foo->can("boogie") ? "yes":"no", "no" );
294 is( $::{"Foo::"} || "none", "none"); # still missing?
296 is( eval 'Foo->boogie(); 1' ? "yes":"no", "no" );
297 is( $::{"Foo::"} || "none", "none"); # still missing?
299 is(do { eval 'Foo->boogie()';
300 $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1);
302 eval 'sub Foo::boogie { "yes, sir!" }';
303 is( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now
304 is( Foo->boogie(), "yes, sir!");
306 # TODO: universal.t should test NoSuchPackage->isa()/can()
308 # This is actually testing parsing of indirect objects and undefined subs
309 # print foo("bar") where foo does not exist is not an indirect object.
310 # print foo "bar" where foo does not exist is an indirect object.
311 eval 'sub AUTOLOAD { "ok ", shift, "\n"; }';
314 # Bug ID 20010902.002
317 my $x = 'x'; # Lexical or package variable, 5.6.1 panics.
318 sub Foo::x : lvalue { $x }
323 # An autoloaded, inherited DESTROY may be invoked differently than normal
324 # methods, and has been known to give rise to spurious warnings
325 # eg <200203121600.QAA11064@gizmo.fdgroup.co.uk>
330 local $SIG{__WARN__} = sub { $w = $_[0] };
332 sub AutoDest::Base::AUTOLOAD {}
333 @AutoDest::ISA = qw(AutoDest::Base);
334 { my $x = bless {}, 'AutoDest'; }
339 # [ID 20020305.025] PACKAGE::SUPER doesn't work anymore
345 push @main::X, 'Amajor', @_;
351 $_[0]->Bminor::SUPER::test('x', 'y');
352 push @main::X, 'Bminor', @_;
354 Bminor->test('y', 'z');
355 is("@X", "Amajor Bminor x y Bminor Bminor y z");
358 for my $meth (['Bar', 'Foo::Bar'],
359 ['SUPER::Bar', 'main::SUPER::Bar'],
360 ['Xyz::SUPER::Bar', 'Xyz::SUPER::Bar'])
363 package UNIVERSAL; sub AUTOLOAD { my \$c = shift; print "\$c \$AUTOLOAD\\n" }
364 sub DESTROY {} # prevent AUTOLOAD being called on DESTROY
366 package main; Foo->$meth->[0]();
369 { switches => [ '-w' ] },
370 "check if UNIVERSAL::AUTOLOAD works",
374 # Test for #71952: crash when looking for a nonexistent destructor
375 # Regression introduced by fbb3ee5af3d4
377 fresh_perl_is(<<'EOT',
378 sub M::DESTROY; bless {}, "M" ; print "survived\n";
382 "no crash with a declared but missing DESTROY method"
386 # Test for calling a method on a packag name return by a magic variable
387 sub TIESCALAR{bless[]}
390 sub bolgy { ++$kalled; }
393 is $kalled, 1, 'calling a class method via a magic variable';
401 NulTest->${ \"method\0Whoops" };
403 like $@, qr/Can't locate object method "method\0Whoops" via package "NulTest" at/,
404 "method lookup is nul-clean";
406 *NulTest::AUTOLOAD = sub { our $AUTOLOAD; return $AUTOLOAD };
408 like(NulTest->${ \"nul\0test" }, qr/nul\0test/, "AUTOLOAD is nul-clean");
414 q! sub T::DESTROY { $x = $_[0]; } bless [], "T";!,
415 "DESTROY created new reference to dead object 'T' during global destruction.",
417 "DESTROY creating a new reference to the object generates a warning."
424 sub Just::a_japh { return "$_[0] another Perl hacker," }
425 is eval { "Just"->a_japh }, "Just another Perl hacker,",
426 'constants do not interfere with class methods';
433 sub lbiggles :lvalue { index "foo", "f" }
434 ok eval { main->bliggles(my($foo,$bar)) },
435 'foo->bar(my($foo,$bar)) is not called in lvalue context';
436 ok eval { main->bliggles(our($foo,$bar)) },
437 'foo->bar(our($foo,$bar)) is not called in lvalue context';
438 ok eval { main->bliggles(local($foo,$bar)) },
439 'foo->bar(local($foo,$bar)) is not called in lvalue context';
440 ok eval { () = main->lbiggles(my($foo,$bar)); 1 },
441 'foo->lv(my($foo,$bar)) is not called in lvalue context';
442 ok eval { () = main->lbiggles(our($foo,$bar)); 1 },
443 'foo->lv(our($foo,$bar)) is not called in lvalue context';
444 ok eval { () = main->lbiggles(local($foo,$bar)); 1 },
445 'foo->lv(local($foo,$bar)) is not called in lvalue context';
449 # AUTOLOAD and DESTROY can be declared without a leading sub,
450 # like BEGIN and friends.
453 eval 'AUTOLOAD { our $AUTOLOAD; return $AUTOLOAD }';
454 ::ok( !$@, "AUTOLOAD without a leading sub is legal" );
456 eval "DESTROY { ::pass( q!DESTROY without a leading sub is legal and gets called! ) }";
458 ::ok( NoSub->can("AUTOLOAD"), "...and sets up an AUTOLOAD normally" );
459 ::is( eval { NoSub->bluh }, "NoSub::bluh", "...which works as expected" );
461 { bless {}, "NoSub"; }
467 package AutoloadDestroy;
468 sub AUTOLOAD { $autoloaded = 1 }
470 bless {}, "AutoloadDestroy";
471 ok($autoloaded, "AUTOLOAD called for DESTROY");
473 # 127494 - AUTOLOAD for DESTROY was called without setting $AUTOLOAD
474 local $::TODO = "caching of AUTOLOAD for DESTROY didn't set \$AUTOLOAD";
476 package AutoloadDestroy2;
479 (my $method = $AUTOLOAD) =~ s/.*:://;
483 # this cached AUTOLOAD as the DESTROY method
484 bless {}, "AutoloadDestroy2";
486 my $o = bless {}, "AutoloadDestroy2";
487 # this sets $AUTOLOAD to "AutoloadDestroy2::foo"
489 # this would call AUTOLOAD without setting $AUTOLOAD
491 ok($methods{DESTROY}, "\$AUTOLOAD set correctly for DESTROY");
494 eval { () = 3; new {} };
496 qr/^Can't call method "new" without a package or object reference/,
497 'Err msg from new{} when stack contains a number';
498 eval { () = "foo"; new {} };
500 qr/^Can't call method "new" without a package or object reference/,
501 'Err msg from new{} when stack contains a word';
502 eval { () = undef; new {} };
504 qr/^Can't call method "new" without a package or object reference/,
505 'Err msg from new{} when stack contains undef';
509 sub ASI::m { shift; "@_" };
510 my @a = (bless([]), 'arg');
511 my $r = SUPER::m{@a};
512 ::is $r, 'arg', 'method{@array}';
514 ::is $r, 'arg', 'method{}@array';
515 $r = SUPER::m{@a}"b";
516 ::is $r, 'arg b', 'method{@array}$more_args';
519 # [perl #114924] SUPER->method
520 @SUPER::ISA = "SUPPER";
521 sub SUPPER::foo { "supper" }
522 is "SUPER"->foo, 'supper', 'SUPER->method';
524 sub flomp { "flimp" }
525 sub main::::flomp { "flump" }
526 is "::"->flomp, 'flump', 'method call on ::';
527 is "::main"->flomp, 'flimp', 'method call on ::main';
530 qr/^Can't call method "flomp" without a package or object reference/,
531 'method call on empty string';
532 is "3foo"->CORE::uc, '3FOO', '"3foo"->CORE::uc';
533 { no strict; @{"3foo::ISA"} = "CORE"; }
534 is "3foo"->uc, '3FOO', '"3foo"->uc (autobox style!)';
537 sub myclass::squeak { 'eek' }
538 eval { *myclass->squeak };
540 qr/^Can't call method "squeak" without a package or object reference/,
541 'method call on typeglob ignores package';
542 eval { (\*myclass)->squeak };
544 qr/^Can't call method "squeak" on unblessed reference/,
545 'method call on \*typeglob';
546 *stdout2 = *STDOUT; # stdout2 now stringifies as *main::STDOUT
547 sub IO::Handle::self { $_[0] }
548 # This used to stringify the glob:
549 is *stdout2->self, (\*stdout2)->self,
550 '*glob->method is equiv to (\*glob)->method';
551 sub { $_[0] = *STDOUT; is $_[0]->self, \$::h{k}, '$pvlv_glob->method' }
554 # Test that PL_stashcache doesn't change the resolution behaviour for file
555 # handles and package names.
557 skip_if_miniperl('file handles as methods requires loading IO::File', 26);
560 foreach (qw (Count::DATA Count Colour::H1 Color::H1 C3::H1)) {
565 return "method in $_";
573 *The::Count:: = \*Count::;
576 is(Count::DATA->getline(), 'method in Count::DATA',
577 'initial resolution is a method');
578 is(The::Count::DATA->getline(), 'method in Count::DATA',
579 'initial resolution is a method in aliased classes');
583 is(Count::DATA->getline(), "one! ha ha ha\n", 'file handles take priority');
584 is(The::Count::DATA->getline(), "two! ha ha ha\n",
585 'file handles take priority in aliased classes');
587 eval q{close Count::DATA} or die $!;
591 is(Count::DATA->getline(), undef,
592 "closing a file handle doesn't change object resolution");
593 is(The::Count::DATA->getline(), undef,
594 "closing a file handle doesn't change object resolution in aliased classes");
598 is(Count::DATA->getline(), 'method in Count::DATA',
599 'undefining the typeglob does change object resolution');
600 is(The::Count::DATA->getline(), 'method in Count::DATA',
601 'undefining the typeglob does change object resolution in aliased classes');
603 is(Count->getline(), 'method in Count',
604 'initial resolution is a method');
605 is(The::Count->getline(), 'method in Count',
606 'initial resolution is a method in aliased classes');
609 open Count, '<', $INC{'Count.pm'}
610 or die "Can't open $INC{'Count.pm'}: $!";
614 is(Count->getline(), "# zero! ha ha ha\n", 'file handles take priority');
615 is(The::Count->getline(), 'method in Count', 'but not in an aliased class');
617 eval q{close Count} or die $!;
621 is(Count->getline(), undef,
622 "closing a file handle doesn't change object resolution");
626 is(Count->getline(), 'method in Count',
627 'undefining the typeglob does change object resolution');
629 open Colour::H1, 'op/method.t' or die $!;
630 while (<Colour::H1>) {
633 open CLOSED, 'TEST' or die $!;
634 close CLOSED or die $!;
636 my $fh_start = tell Colour::H1;
637 my $data_start = tell DATA;
638 is(Colour::H1->getline(), <DATA>, 'read from a file');
639 is(Color::H1->getline(), 'method in Color::H1',
640 'initial resolution is a method');
642 *Color::H1 = *Colour::H1{IO};
644 is(Colour::H1->getline(), <DATA>, 'read from a file');
645 is(Color::H1->getline(), <DATA>,
646 'file handles take priority after io-to-typeglob assignment');
648 *Color::H1 = *CLOSED{IO};
651 is(Color::H1->getline(), undef,
652 "assigning a closed a file handle doesn't change object resolution");
656 is(Color::H1->getline(), 'method in Color::H1',
657 'undefining the typeglob does change object resolution');
659 *Color::H1 = *Colour::H1;
661 is(Color::H1->getline(), <DATA>,
662 'file handles take priority after typeglob-to-typeglob assignment');
664 seek Colour::H1, $fh_start, Fcntl::SEEK_SET() or die $!;
665 seek DATA, $data_start, Fcntl::SEEK_SET() or die $!;
667 is(Colour::H1->getline(), <DATA>, 'read from a file');
668 is(C3::H1->getline(), 'method in C3::H1', 'initial resolution is a method');
673 is(Colour::H1->getline(), <DATA>, 'read from a file');
674 is(C3::H1->getline(), <DATA>,
675 'file handles take priority after stash aliasing');
679 is(C3::H1->getline(), 'method in C3::H1',
680 'restoring the stash returns to a method');
683 # RT #123619 constant class name should be read-only
686 sub RT123619::f { chop $_[0] }
687 eval { 'RT123619'->f(); };
688 like ($@, qr/Modification of a read-only value attempted/, 'RT #123619');
692 # RT #126042 &{1==1} * &{1==1} would crash
694 # pp_entersub and pp_method_named cooperate to prevent calls to an
695 # undefined import() or unimport() method from croaking.
696 # If pp_method_named can't find the method it pushes &PL_sv_yes, and
697 # pp_entersub checks for that specific SV to avoid croaking.
698 # Ideally they wouldn't use that hack but...
699 # Unfortunately pp_entersub's handling of that case is broken in scalar context.
701 # Rather than using the test case from the ticket, since &{1==1}
702 # isn't documented (and may not be supported in future perls) test
703 # calls to undefined import method, which also crashes.
704 fresh_perl_is('Unknown->import() * Unknown->unimport(); print "ok\n"', "ok\n", {},
705 "check unknown import() methods don't corrupt the stack");