1#!./perl 2 3# 4# test method calls and autoloading. 5# 6 7BEGIN { 8 chdir 't' if -d 't'; 9 @INC = qw(. ../lib); 10 require "test.pl"; 11} 12 13print "1..78\n"; 14 15@A::ISA = 'B'; 16@B::ISA = 'C'; 17 18sub C::d {"C::d"} 19sub D::d {"D::d"} 20 21# First, some basic checks of method-calling syntax: 22$obj = bless [], "Pack"; 23sub Pack::method { shift; join(",", "method", @_) } 24$mname = "method"; 25 26is(Pack->method("a","b","c"), "method,a,b,c"); 27is(Pack->$mname("a","b","c"), "method,a,b,c"); 28is(method Pack ("a","b","c"), "method,a,b,c"); 29is((method Pack "a","b","c"), "method,a,b,c"); 30 31is(Pack->method(), "method"); 32is(Pack->$mname(), "method"); 33is(method Pack (), "method"); 34is(Pack->method, "method"); 35is(Pack->$mname, "method"); 36is(method Pack, "method"); 37 38is($obj->method("a","b","c"), "method,a,b,c"); 39is($obj->$mname("a","b","c"), "method,a,b,c"); 40is((method $obj ("a","b","c")), "method,a,b,c"); 41is((method $obj "a","b","c"), "method,a,b,c"); 42 43is($obj->method(0), "method,0"); 44is($obj->method(1), "method,1"); 45 46is($obj->method(), "method"); 47is($obj->$mname(), "method"); 48is((method $obj ()), "method"); 49is($obj->method, "method"); 50is($obj->$mname, "method"); 51is(method $obj, "method"); 52 53is( A->d, "C::d"); # Update hash table; 54 55*B::d = \&D::d; # Import now. 56is(A->d, "D::d"); # Update hash table; 57 58{ 59 local @A::ISA = qw(C); # Update hash table with split() assignment 60 is(A->d, "C::d"); 61 $#A::ISA = -1; 62 is(eval { A->d } || "fail", "fail"); 63} 64is(A->d, "D::d"); 65 66{ 67 local *B::d; 68 eval 'sub B::d {"B::d1"}'; # Import now. 69 is(A->d, "B::d1"); # Update hash table; 70 undef &B::d; 71 is((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); 72} 73 74is(A->d, "D::d"); # Back to previous state 75 76eval 'sub B::d {"B::d2"}'; # Import now. 77is(A->d, "B::d2"); # Update hash table; 78 79# What follows is hardly guarantied to work, since the names in scripts 80# are already linked to "pruned" globs. Say, `undef &B::d' if it were 81# after `delete $B::{d}; sub B::d {}' would reach an old subroutine. 82 83undef &B::d; 84delete $B::{d}; 85is(A->d, "C::d"); # Update hash table; 86 87eval 'sub B::d {"B::d3"}'; # Import now. 88is(A->d, "B::d3"); # Update hash table; 89 90delete $B::{d}; 91*dummy::dummy = sub {}; # Mark as updated 92is(A->d, "C::d"); 93 94eval 'sub B::d {"B::d4"}'; # Import now. 95is(A->d, "B::d4"); # Update hash table; 96 97delete $B::{d}; # Should work without any help too 98is(A->d, "C::d"); 99 100{ 101 local *C::d; 102 is(eval { A->d } || "nope", "nope"); 103} 104is(A->d, "C::d"); 105 106*A::x = *A::d; # See if cache incorrectly follows synonyms 107A->d; 108is(eval { A->x } || "nope", "nope"); 109 110eval <<'EOF'; 111sub C::e; 112BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg 113sub Y::f; 114$counter = 0; 115 116@X::ISA = 'Y'; 117@Y::ISA = 'B'; 118 119sub B::AUTOLOAD { 120 my $c = ++$counter; 121 my $method = $B::AUTOLOAD; 122 my $msg = "B: In $method, $c"; 123 eval "sub $method { \$msg }"; 124 goto &$method; 125} 126sub C::AUTOLOAD { 127 my $c = ++$counter; 128 my $method = $C::AUTOLOAD; 129 my $msg = "C: In $method, $c"; 130 eval "sub $method { \$msg }"; 131 goto &$method; 132} 133EOF 134 135is(A->e(), "C: In C::e, 1"); # We get a correct autoload 136is(A->e(), "C: In C::e, 1"); # Which sticks 137 138is(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top 139is(A->ee(), "B: In A::ee, 2"); # Which sticks 140 141is(Y->f(), "B: In Y::f, 3"); # We vivify a correct method 142is(Y->f(), "B: In Y::f, 3"); # Which sticks 143 144# This test is not intended to be reasonable. It is here just to let you 145# know that you broke some old construction. Feel free to rewrite the test 146# if your patch breaks it. 147 148*B::AUTOLOAD = sub { 149 my $c = ++$counter; 150 my $method = $AUTOLOAD; 151 *$AUTOLOAD = sub { "new B: In $method, $c" }; 152 goto &$AUTOLOAD; 153}; 154 155is(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload 156is(A->eee(), "new B: In A::eee, 4"); # Which sticks 157 158# this test added due to bug discovery 159is(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); 160 161# test that failed subroutine calls don't affect method calls 162{ 163 package A1; 164 sub foo { "foo" } 165 package A2; 166 @ISA = 'A1'; 167 package main; 168 is(A2->foo(), "foo"); 169 is(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); 170 is(A2->foo(), "foo"); 171} 172 173## This test was totally misguided. It passed before only because the 174## code to determine if a package was loaded used to look for the hash 175## %Foo::Bar instead of the package Foo::Bar:: -- and Config.pm just 176## happens to export %Config. 177# { 178# is(do { use Config; eval 'Config->foo()'; 179# $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); 180# is(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; 181# $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); 182# } 183 184 185# test error messages if method loading fails 186is(do { eval '$e = bless {}, "E::A"; E::A->foo()'; 187 $@ =~ /^\QCan't locate object method "foo" via package "E::A" at/ ? 1 : $@}, 1); 188is(do { eval '$e = bless {}, "E::B"; $e->foo()'; 189 $@ =~ /^\QCan't locate object method "foo" via package "E::B" at/ ? 1 : $@}, 1); 190is(do { eval 'E::C->foo()'; 191 $@ =~ /^\QCan't locate object method "foo" via package "E::C" (perhaps / ? 1 : $@}, 1); 192 193is(do { eval 'UNIVERSAL->E::D::foo()'; 194 $@ =~ /^\QCan't locate object method "foo" via package "E::D" (perhaps / ? 1 : $@}, 1); 195is(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::E::foo()'; 196 $@ =~ /^\QCan't locate object method "foo" via package "E::E" (perhaps / ? 1 : $@}, 1); 197 198$e = bless {}, "E::F"; # force package to exist 199is(do { eval 'UNIVERSAL->E::F::foo()'; 200 $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1); 201is(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()'; 202 $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1); 203 204# TODO: we need some tests for the SUPER:: pseudoclass 205 206# failed method call or UNIVERSAL::can() should not autovivify packages 207is( $::{"Foo::"} || "none", "none"); # sanity check 1 208is( $::{"Foo::"} || "none", "none"); # sanity check 2 209 210is( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" ); 211is( $::{"Foo::"} || "none", "none"); # still missing? 212 213is( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" ); 214is( $::{"Foo::"} || "none", "none"); # still missing? 215 216is( Foo->can("boogie") ? "yes":"no", "no" ); 217is( $::{"Foo::"} || "none", "none"); # still missing? 218 219is( eval 'Foo->boogie(); 1' ? "yes":"no", "no" ); 220is( $::{"Foo::"} || "none", "none"); # still missing? 221 222is(do { eval 'Foo->boogie()'; 223 $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1); 224 225eval 'sub Foo::boogie { "yes, sir!" }'; 226is( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now 227is( Foo->boogie(), "yes, sir!"); 228 229# TODO: universal.t should test NoSuchPackage->isa()/can() 230 231# This is actually testing parsing of indirect objects and undefined subs 232# print foo("bar") where foo does not exist is not an indirect object. 233# print foo "bar" where foo does not exist is an indirect object. 234eval 'sub AUTOLOAD { "ok ", shift, "\n"; }'; 235ok(1); 236 237# Bug ID 20010902.002 238is( 239 eval q[ 240 $x = 'x'; 241 sub Foo::x : lvalue { $x } 242 Foo->$x = 'ok'; 243 ] || $@, 'ok' 244); 245 246# An autoloaded, inherited DESTROY may be invoked differently than normal 247# methods, and has been known to give rise to spurious warnings 248# eg <200203121600.QAA11064@gizmo.fdgroup.co.uk> 249 250{ 251 use warnings; 252 my $w = ''; 253 local $SIG{__WARN__} = sub { $w = $_[0] }; 254 255 sub AutoDest::Base::AUTOLOAD {} 256 @AutoDest::ISA = qw(AutoDest::Base); 257 { my $x = bless {}, 'AutoDest'; } 258 $w =~ s/\n//g; 259 is($w, ''); 260} 261 262# [ID 20020305.025] PACKAGE::SUPER doesn't work anymore 263 264package main; 265our @X; 266package Amajor; 267sub test { 268 push @main::X, 'Amajor', @_; 269} 270package Bminor; 271use base qw(Amajor); 272package main; 273sub Bminor::test { 274 $_[0]->Bminor::SUPER::test('x', 'y'); 275 push @main::X, 'Bminor', @_; 276} 277Bminor->test('y', 'z'); 278is("@X", "Amajor Bminor x y Bminor Bminor y z"); 279 280package main; 281for my $meth (['Bar', 'Foo::Bar'], 282 ['SUPER::Bar', 'main::SUPER::Bar'], 283 ['Xyz::SUPER::Bar', 'Xyz::SUPER::Bar']) 284{ 285 fresh_perl_is(<<EOT, 286package UNIVERSAL; sub AUTOLOAD { my \$c = shift; print "\$c \$AUTOLOAD\\n" } 287sub DESTROY {} # IO object destructor called in MacOS, because of Mac::err 288package Xyz; 289package main; Foo->$meth->[0](); 290EOT 291 "Foo $meth->[1]", 292 { switches => [ '-w' ] }, 293 "check if UNIVERSAL::AUTOLOAD works", 294 ); 295} 296