Commit | Line | Data |
---|---|---|
9bfdb36e | 1 | #!./perl -w |
92d69e20 IZ |
2 | |
3 | # | |
4 | # test method calls and autoloading. | |
5 | # | |
6 | ||
4755096e GS |
7 | BEGIN { |
8 | chdir 't' if -d 't'; | |
6f908f1b | 9 | @INC = qw(. ../lib lib); |
6dc4e5ce | 10 | require "test.pl"; |
4755096e GS |
11 | } |
12 | ||
9bfdb36e NC |
13 | use strict; |
14 | no warnings 'once'; | |
15 | ||
257dc59d | 16 | plan(tests => 147); |
92d69e20 IZ |
17 | |
18 | @A::ISA = 'B'; | |
19 | @B::ISA = 'C'; | |
20 | ||
21 | sub C::d {"C::d"} | |
22 | sub D::d {"D::d"} | |
23 | ||
567ce7b1 | 24 | # First, some basic checks of method-calling syntax: |
9bfdb36e | 25 | my $obj = bless [], "Pack"; |
567ce7b1 | 26 | sub Pack::method { shift; join(",", "method", @_) } |
9bfdb36e | 27 | my $mname = "method"; |
567ce7b1 | 28 | |
6dc4e5ce JH |
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"); | |
567ce7b1 | 33 | |
6dc4e5ce JH |
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"); | |
567ce7b1 | 40 | |
6dc4e5ce JH |
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"); | |
145eb477 | 45 | |
6dc4e5ce JH |
46 | is($obj->method(0), "method,0"); |
47 | is($obj->method(1), "method,1"); | |
567ce7b1 | 48 | |
6dc4e5ce JH |
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"); | |
567ce7b1 | 55 | |
6dc4e5ce | 56 | is( A->d, "C::d"); # Update hash table; |
92d69e20 IZ |
57 | |
58 | *B::d = \&D::d; # Import now. | |
6dc4e5ce | 59 | is(A->d, "D::d"); # Update hash table; |
92d69e20 | 60 | |
44a8e56a | 61 | { |
fb73857a | 62 | local @A::ISA = qw(C); # Update hash table with split() assignment |
6dc4e5ce | 63 | is(A->d, "C::d"); |
fb73857a | 64 | $#A::ISA = -1; |
6dc4e5ce | 65 | is(eval { A->d } || "fail", "fail"); |
fb73857a | 66 | } |
6dc4e5ce | 67 | is(A->d, "D::d"); |
fb73857a | 68 | |
69 | { | |
44a8e56a | 70 | local *B::d; |
71 | eval 'sub B::d {"B::d1"}'; # Import now. | |
6dc4e5ce | 72 | is(A->d, "B::d1"); # Update hash table; |
44a8e56a | 73 | undef &B::d; |
6dc4e5ce | 74 | is((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); |
44a8e56a | 75 | } |
92d69e20 | 76 | |
6dc4e5ce | 77 | is(A->d, "D::d"); # Back to previous state |
92d69e20 | 78 | |
9bfdb36e | 79 | eval 'no warnings "redefine"; sub B::d {"B::d2"}'; # Import now. |
6dc4e5ce | 80 | is(A->d, "B::d2"); # Update hash table; |
92d69e20 IZ |
81 | |
82 | # What follows is hardly guarantied to work, since the names in scripts | |
94e1fbae JK |
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. | |
92d69e20 IZ |
85 | |
86 | undef &B::d; | |
87 | delete $B::{d}; | |
5743f2a3 FC |
88 | is(A->d, "C::d"); |
89 | ||
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 | |
6dc4e5ce | 93 | is(A->d, "C::d"); # Update hash table; |
92d69e20 IZ |
94 | |
95 | eval 'sub B::d {"B::d3"}'; # Import now. | |
6dc4e5ce | 96 | is(A->d, "B::d3"); # Update hash table; |
92d69e20 IZ |
97 | |
98 | delete $B::{d}; | |
99 | *dummy::dummy = sub {}; # Mark as updated | |
6dc4e5ce | 100 | is(A->d, "C::d"); |
92d69e20 IZ |
101 | |
102 | eval 'sub B::d {"B::d4"}'; # Import now. | |
6dc4e5ce | 103 | is(A->d, "B::d4"); # Update hash table; |
92d69e20 IZ |
104 | |
105 | delete $B::{d}; # Should work without any help too | |
6dc4e5ce | 106 | is(A->d, "C::d"); |
92d69e20 | 107 | |
fae75791 CS |
108 | { |
109 | local *C::d; | |
6dc4e5ce | 110 | is(eval { A->d } || "nope", "nope"); |
fae75791 | 111 | } |
6dc4e5ce | 112 | is(A->d, "C::d"); |
fae75791 | 113 | |
9bfdb36e | 114 | *A::x = *A::d; |
44a8e56a | 115 | A->d; |
9bfdb36e NC |
116 | is(eval { A->x } || "nope", "nope", 'cache should not follow synonyms'); |
117 | ||
118 | my $counter; | |
44a8e56a | 119 | |
92d69e20 IZ |
120 | eval <<'EOF'; |
121 | sub C::e; | |
09280a33 | 122 | BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg |
92d69e20 IZ |
123 | sub Y::f; |
124 | $counter = 0; | |
125 | ||
54310121 | 126 | @X::ISA = 'Y'; |
dc848c6f | 127 | @Y::ISA = 'B'; |
92d69e20 IZ |
128 | |
129 | sub B::AUTOLOAD { | |
130 | my $c = ++$counter; | |
131 | my $method = $B::AUTOLOAD; | |
09280a33 CS |
132 | my $msg = "B: In $method, $c"; |
133 | eval "sub $method { \$msg }"; | |
134 | goto &$method; | |
92d69e20 IZ |
135 | } |
136 | sub C::AUTOLOAD { | |
137 | my $c = ++$counter; | |
138 | my $method = $C::AUTOLOAD; | |
09280a33 CS |
139 | my $msg = "C: In $method, $c"; |
140 | eval "sub $method { \$msg }"; | |
141 | goto &$method; | |
92d69e20 IZ |
142 | } |
143 | EOF | |
144 | ||
6dc4e5ce JH |
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 | |
92d69e20 | 147 | |
6dc4e5ce JH |
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 | |
92d69e20 | 150 | |
6dc4e5ce JH |
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 | |
92d69e20 IZ |
153 | |
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. | |
157 | ||
9bfdb36e NC |
158 | { |
159 | no warnings 'redefine'; | |
92d69e20 | 160 | *B::AUTOLOAD = sub { |
9bfdb36e | 161 | use warnings; |
92d69e20 | 162 | my $c = ++$counter; |
9bfdb36e NC |
163 | my $method = $::AUTOLOAD; |
164 | no strict 'refs'; | |
165 | *$::AUTOLOAD = sub { "new B: In $method, $c" }; | |
166 | goto &$::AUTOLOAD; | |
92d69e20 | 167 | }; |
9bfdb36e | 168 | } |
92d69e20 | 169 | |
6dc4e5ce JH |
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 | |
fb73857a | 172 | |
9bfdb36e NC |
173 | { |
174 | no strict 'refs'; | |
33f89799 | 175 | no warnings 'deprecated'; |
9bfdb36e | 176 | # this test added due to bug discovery (in 5.004_04, fb73857aa0bfa8ed) |
33f89799 NC |
177 | # Possibly kill this test now that defined @::array is finally properly |
178 | # deprecated? | |
9bfdb36e NC |
179 | is(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); |
180 | } | |
f6ec51f7 GS |
181 | |
182 | # test that failed subroutine calls don't affect method calls | |
183 | { | |
184 | package A1; | |
185 | sub foo { "foo" } | |
186 | package A2; | |
9bfdb36e | 187 | @A2::ISA = 'A1'; |
f6ec51f7 | 188 | package main; |
6dc4e5ce JH |
189 | is(A2->foo(), "foo"); |
190 | is(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); | |
191 | is(A2->foo(), "foo"); | |
f6ec51f7 | 192 | } |
c1899e02 | 193 | |
af09ea45 IK |
194 | ## This test was totally misguided. It passed before only because the |
195 | ## code to determine if a package was loaded used to look for the hash | |
196 | ## %Foo::Bar instead of the package Foo::Bar:: -- and Config.pm just | |
197 | ## happens to export %Config. | |
198 | # { | |
6dc4e5ce | 199 | # is(do { use Config; eval 'Config->foo()'; |
af09ea45 | 200 | # $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); |
6dc4e5ce | 201 | # is(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; |
af09ea45 IK |
202 | # $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); |
203 | # } | |
204 | ||
af09ea45 | 205 | # test error messages if method loading fails |
9bfdb36e NC |
206 | my $e; |
207 | ||
2f907243 NC |
208 | eval '$e = bless {}, "E::A"; E::A->foo()'; |
209 | like ($@, qr/^\QCan't locate object method "foo" via package "E::A" at/); | |
210 | eval '$e = bless {}, "E::B"; $e->foo()'; | |
211 | like ($@, qr/^\QCan't locate object method "foo" via package "E::B" at/); | |
212 | eval 'E::C->foo()'; | |
213 | like ($@, qr/^\QCan't locate object method "foo" via package "E::C" (perhaps /); | |
214 | ||
215 | eval 'UNIVERSAL->E::D::foo()'; | |
216 | like ($@, qr/^\QCan't locate object method "foo" via package "E::D" (perhaps /); | |
9bfdb36e | 217 | eval 'my $e = bless {}, "UNIVERSAL"; $e->E::E::foo()'; |
2f907243 | 218 | like ($@, qr/^\QCan't locate object method "foo" via package "E::E" (perhaps /); |
af09ea45 IK |
219 | |
220 | $e = bless {}, "E::F"; # force package to exist | |
2f907243 NC |
221 | eval 'UNIVERSAL->E::F::foo()'; |
222 | like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/); | |
223 | eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()'; | |
224 | like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/); | |
af09ea45 | 225 | |
697efb9b FC |
226 | # SUPER:: pseudoclass |
227 | @Saab::ISA = "Souper"; | |
228 | sub Souper::method { @_ } | |
229 | @OtherSaab::ISA = "OtherSouper"; | |
230 | sub OtherSouper::method { "Isidore Ropen, Draft Manager" } | |
231 | { | |
232 | my $o = bless [], "Saab"; | |
233 | package Saab; | |
234 | my @ret = $o->SUPER::method('whatever'); | |
235 | ::is $ret[0], $o, 'object passed to SUPER::method'; | |
236 | ::is $ret[1], 'whatever', 'argument passed to SUPER::method'; | |
237 | @ret = $o->SUPER'method('whatever'); | |
238 | ::is $ret[0], $o, "object passed to SUPER'method"; | |
239 | ::is $ret[1], 'whatever', "argument passed to SUPER'method"; | |
240 | @ret = Saab->SUPER::method; | |
241 | ::is $ret[0], 'Saab', "package name passed to SUPER::method"; | |
242 | @ret = OtherSaab->SUPER::method; | |
243 | ::is $ret[0], 'OtherSaab', | |
244 | "->SUPER::method uses current package, not invocant"; | |
245 | } | |
3c104e59 FC |
246 | () = *SUPER::; |
247 | { | |
248 | local our @ISA = "Souper"; | |
249 | is eval { (main->SUPER::method)[0] }, 'main', | |
250 | 'Mentioning *SUPER:: does not stop ->SUPER from working in main'; | |
251 | } | |
0308a534 FC |
252 | { |
253 | BEGIN { | |
254 | *Mover:: = *Mover2::; | |
255 | *Mover2:: = *foo; | |
256 | } | |
257 | package Mover; | |
258 | no strict; | |
259 | # Not our(@ISA), because the bug we are testing for interacts with an | |
260 | # our() bug that cancels this bug out. | |
261 | @ISA = 'door'; | |
262 | sub door::dohtem { 'dohtem' } | |
263 | ::is eval { Mover->SUPER::dohtem; }, 'dohtem', | |
264 | 'SUPER inside moved package'; | |
37b0b3b2 FC |
265 | undef *door::dohtem; |
266 | *door::dohtem = sub { 'method' }; | |
267 | ::is eval { Mover->SUPER::dohtem; }, 'method', | |
268 | 'SUPER inside moved package respects method changes'; | |
0308a534 | 269 | } |
af09ea45 | 270 | |
257dc59d FC |
271 | package foo120694 { |
272 | BEGIN { our @ISA = qw(bar120694) } | |
273 | ||
274 | sub AUTOLOAD { | |
275 | my $self = shift; | |
276 | local our $recursive = $recursive; | |
277 | return "recursive" if $recursive++; | |
278 | return if our $AUTOLOAD eq 'DESTROY'; | |
279 | $AUTOLOAD = "SUPER:" . substr $AUTOLOAD, rindex($AUTOLOAD, ':'); | |
280 | return $self->$AUTOLOAD(@_); | |
281 | } | |
282 | } | |
283 | package bar120694 { | |
284 | sub AUTOLOAD { | |
285 | return "xyzzy"; | |
286 | } | |
287 | } | |
288 | is bless( [] => "foo120694" )->plugh, 'xyzzy', | |
289 | '->SUPER::method autoloading uses parent of current pkg'; | |
290 | ||
291 | ||
af09ea45 | 292 | # failed method call or UNIVERSAL::can() should not autovivify packages |
6dc4e5ce JH |
293 | is( $::{"Foo::"} || "none", "none"); # sanity check 1 |
294 | is( $::{"Foo::"} || "none", "none"); # sanity check 2 | |
c1899e02 | 295 | |
6dc4e5ce JH |
296 | is( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" ); |
297 | is( $::{"Foo::"} || "none", "none"); # still missing? | |
af09ea45 | 298 | |
6dc4e5ce JH |
299 | is( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" ); |
300 | is( $::{"Foo::"} || "none", "none"); # still missing? | |
af09ea45 | 301 | |
6dc4e5ce JH |
302 | is( Foo->can("boogie") ? "yes":"no", "no" ); |
303 | is( $::{"Foo::"} || "none", "none"); # still missing? | |
af09ea45 | 304 | |
6dc4e5ce JH |
305 | is( eval 'Foo->boogie(); 1' ? "yes":"no", "no" ); |
306 | is( $::{"Foo::"} || "none", "none"); # still missing? | |
af09ea45 | 307 | |
6dc4e5ce | 308 | is(do { eval 'Foo->boogie()'; |
af09ea45 IK |
309 | $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1); |
310 | ||
311 | eval 'sub Foo::boogie { "yes, sir!" }'; | |
6dc4e5ce JH |
312 | is( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now |
313 | is( Foo->boogie(), "yes, sir!"); | |
af09ea45 IK |
314 | |
315 | # TODO: universal.t should test NoSuchPackage->isa()/can() | |
c1899e02 | 316 | |
f0670693 SC |
317 | # This is actually testing parsing of indirect objects and undefined subs |
318 | # print foo("bar") where foo does not exist is not an indirect object. | |
319 | # print foo "bar" where foo does not exist is an indirect object. | |
84251760 | 320 | eval 'sub AUTOLOAD { "ok ", shift, "\n"; }'; |
6dc4e5ce | 321 | ok(1); |
af09ea45 | 322 | |
a397c3d9 | 323 | # Bug ID 20010902.002 |
6dc4e5ce | 324 | is( |
a397c3d9 | 325 | eval q[ |
9bfdb36e | 326 | my $x = 'x'; # Lexical or package variable, 5.6.1 panics. |
a397c3d9 RGS |
327 | sub Foo::x : lvalue { $x } |
328 | Foo->$x = 'ok'; | |
329 | ] || $@, 'ok' | |
330 | ); | |
331 | ||
3ad83ce7 AMS |
332 | # An autoloaded, inherited DESTROY may be invoked differently than normal |
333 | # methods, and has been known to give rise to spurious warnings | |
334 | # eg <200203121600.QAA11064@gizmo.fdgroup.co.uk> | |
335 | ||
336 | { | |
337 | use warnings; | |
338 | my $w = ''; | |
339 | local $SIG{__WARN__} = sub { $w = $_[0] }; | |
340 | ||
341 | sub AutoDest::Base::AUTOLOAD {} | |
342 | @AutoDest::ISA = qw(AutoDest::Base); | |
343 | { my $x = bless {}, 'AutoDest'; } | |
344 | $w =~ s/\n//g; | |
6dc4e5ce | 345 | is($w, ''); |
3ad83ce7 AMS |
346 | } |
347 | ||
e189a56d IK |
348 | # [ID 20020305.025] PACKAGE::SUPER doesn't work anymore |
349 | ||
350 | package main; | |
351 | our @X; | |
352 | package Amajor; | |
353 | sub test { | |
354 | push @main::X, 'Amajor', @_; | |
355 | } | |
356 | package Bminor; | |
357 | use base qw(Amajor); | |
358 | package main; | |
359 | sub Bminor::test { | |
360 | $_[0]->Bminor::SUPER::test('x', 'y'); | |
361 | push @main::X, 'Bminor', @_; | |
362 | } | |
363 | Bminor->test('y', 'z'); | |
364 | is("@X", "Amajor Bminor x y Bminor Bminor y z"); | |
365 | ||
0dae17bd GS |
366 | package main; |
367 | for my $meth (['Bar', 'Foo::Bar'], | |
368 | ['SUPER::Bar', 'main::SUPER::Bar'], | |
369 | ['Xyz::SUPER::Bar', 'Xyz::SUPER::Bar']) | |
370 | { | |
371 | fresh_perl_is(<<EOT, | |
372 | package UNIVERSAL; sub AUTOLOAD { my \$c = shift; print "\$c \$AUTOLOAD\\n" } | |
373 | package Xyz; | |
374 | package main; Foo->$meth->[0](); | |
375 | EOT | |
376 | "Foo $meth->[1]", | |
377 | { switches => [ '-w' ] }, | |
378 | "check if UNIVERSAL::AUTOLOAD works", | |
379 | ); | |
380 | } | |
1f15e670 NT |
381 | |
382 | # Test for #71952: crash when looking for a nonexistent destructor | |
383 | # Regression introduced by fbb3ee5af3d4 | |
384 | { | |
385 | fresh_perl_is(<<'EOT', | |
386 | sub M::DESTROY; bless {}, "M" ; print "survived\n"; | |
387 | EOT | |
388 | "survived", | |
389 | {}, | |
390 | "no crash with a declared but missing DESTROY method" | |
391 | ); | |
392 | } | |
393 | ||
da6b625f FC |
394 | # Test for calling a method on a packag name return by a magic variable |
395 | sub TIESCALAR{bless[]} | |
396 | sub FETCH{"main"} | |
397 | my $kalled; | |
398 | sub bolgy { ++$kalled; } | |
399 | tie my $a, ""; | |
400 | $a->bolgy; | |
401 | is $kalled, 1, 'calling a class method via a magic variable'; | |
f937af42 BF |
402 | |
403 | { | |
404 | package NulTest; | |
405 | sub method { 1 } | |
406 | ||
407 | package main; | |
408 | eval { | |
409 | NulTest->${ \"method\0Whoops" }; | |
410 | }; | |
411 | like $@, qr/Can't locate object method "method\0Whoops" via package "NulTest" at/, | |
412 | "method lookup is nul-clean"; | |
413 | ||
414 | *NulTest::AUTOLOAD = sub { our $AUTOLOAD; return $AUTOLOAD }; | |
415 | ||
416 | like(NulTest->${ \"nul\0test" }, "nul\0test", "AUTOLOAD is nul-clean"); | |
417 | } | |
2a0f5ef0 BF |
418 | |
419 | ||
420 | { | |
421 | fresh_perl_is( | |
422 | q! sub T::DESTROY { $x = $_[0]; } bless [], "T";!, | |
423 | "DESTROY created new reference to dead object 'T' during global destruction.", | |
424 | {}, | |
425 | "DESTROY creating a new reference to the object generates a warning." | |
426 | ); | |
427 | } | |
71481574 FC |
428 | |
429 | # [perl #43663] | |
430 | { | |
431 | $::{"Just"} = \1; | |
432 | sub Just::a_japh { return "$_[0] another Perl hacker," } | |
433 | is eval { "Just"->a_japh }, "Just another Perl hacker,", | |
434 | 'constants do not interfere with class methods'; | |
435 | } | |
0865059d FC |
436 | |
437 | # [perl #109264] | |
438 | { | |
439 | no strict 'vars'; | |
440 | sub bliggles { 1 } | |
441 | sub lbiggles :lvalue { index "foo", "f" } | |
442 | ok eval { main->bliggles(my($foo,$bar)) }, | |
443 | 'foo->bar(my($foo,$bar)) is not called in lvalue context'; | |
444 | ok eval { main->bliggles(our($foo,$bar)) }, | |
445 | 'foo->bar(our($foo,$bar)) is not called in lvalue context'; | |
446 | ok eval { main->bliggles(local($foo,$bar)) }, | |
447 | 'foo->bar(local($foo,$bar)) is not called in lvalue context'; | |
448 | ok eval { () = main->lbiggles(my($foo,$bar)); 1 }, | |
449 | 'foo->lv(my($foo,$bar)) is not called in lvalue context'; | |
450 | ok eval { () = main->lbiggles(our($foo,$bar)); 1 }, | |
451 | 'foo->lv(our($foo,$bar)) is not called in lvalue context'; | |
452 | ok eval { () = main->lbiggles(local($foo,$bar)); 1 }, | |
453 | 'foo->lv(local($foo,$bar)) is not called in lvalue context'; | |
454 | } | |
544b72e2 BF |
455 | |
456 | { | |
457 | # AUTOLOAD and DESTROY can be declared without a leading sub, | |
458 | # like BEGIN and friends. | |
459 | package NoSub; | |
460 | ||
461 | eval 'AUTOLOAD { our $AUTOLOAD; return $AUTOLOAD }'; | |
462 | ::ok( !$@, "AUTOLOAD without a leading sub is legal" ); | |
463 | ||
464 | eval "DESTROY { ::pass( q!DESTROY without a leading sub is legal and gets called! ) }"; | |
465 | { | |
466 | ::ok( NoSub->can("AUTOLOAD"), "...and sets up an AUTOLOAD normally" ); | |
467 | ::is( eval { NoSub->bluh }, "NoSub::bluh", "...which works as expected" ); | |
468 | } | |
469 | { bless {}, "NoSub"; } | |
470 | } | |
f226e9be FC |
471 | |
472 | eval { () = 3; new {} }; | |
473 | like $@, | |
474 | qr/^Can't call method "new" without a package or object reference/, | |
475 | 'Err msg from new{} when stack contains a number'; | |
476 | eval { () = "foo"; new {} }; | |
477 | like $@, | |
478 | qr/^Can't call method "new" without a package or object reference/, | |
479 | 'Err msg from new{} when stack contains a word'; | |
480 | eval { () = undef; new {} }; | |
481 | like $@, | |
482 | qr/^Can't call method "new" without a package or object reference/, | |
483 | 'Err msg from new{} when stack contains undef'; | |
bfde49d4 FC |
484 | |
485 | package egakacp { | |
486 | our @ISA = 'ASI'; | |
487 | sub ASI::m { shift; "@_" }; | |
488 | my @a = (bless([]), 'arg'); | |
489 | my $r = SUPER::m{@a}; | |
490 | ::is $r, 'arg', 'method{@array}'; | |
491 | $r = SUPER::m{}@a; | |
492 | ::is $r, 'arg', 'method{}@array'; | |
493 | $r = SUPER::m{@a}"b"; | |
494 | ::is $r, 'arg b', 'method{@array}$more_args'; | |
495 | } | |
aae43805 FC |
496 | |
497 | # [perl #114924] SUPER->method | |
498 | @SUPER::ISA = "SUPPER"; | |
499 | sub SUPPER::foo { "supper" } | |
500 | is "SUPER"->foo, 'supper', 'SUPER->method'; | |
7156e69a FC |
501 | |
502 | sub flomp { "flimp" } | |
503 | sub main::::flomp { "flump" } | |
504 | is "::"->flomp, 'flump', 'method call on ::'; | |
505 | is "::main"->flomp, 'flimp', 'method call on ::main'; | |
506 | eval { ""->flomp }; | |
507 | like $@, | |
508 | qr/^Can't call method "flomp" without a package or object reference/, | |
509 | 'method call on empty string'; | |
510 | is "3foo"->CORE::uc, '3FOO', '"3foo"->CORE::uc'; | |
511 | { no strict; @{"3foo::ISA"} = "CORE"; } | |
512 | is "3foo"->uc, '3FOO', '"3foo"->uc (autobox style!)'; | |
6f908f1b | 513 | |
a77c16f7 FC |
514 | # *foo vs (\*foo) |
515 | sub myclass::squeak { 'eek' } | |
516 | eval { *myclass->squeak }; | |
517 | like $@, | |
518 | qr/^Can't call method "squeak" without a package or object reference/, | |
519 | 'method call on typeglob ignores package'; | |
520 | eval { (\*myclass)->squeak }; | |
521 | like $@, | |
522 | qr/^Can't call method "squeak" on unblessed reference/, | |
523 | 'method call on \*typeglob'; | |
524 | *stdout2 = *STDOUT; # stdout2 now stringifies as *main::STDOUT | |
525 | sub IO::Handle::self { $_[0] } | |
526 | # This used to stringify the glob: | |
527 | is *stdout2->self, (\*stdout2)->self, | |
528 | '*glob->method is equiv to (\*glob)->method'; | |
529 | sub { $_[0] = *STDOUT; is $_[0]->self, \$::h{k}, '$pvlv_glob->method' } | |
530 | ->($::h{k}); | |
531 | ||
6f908f1b NC |
532 | # Test that PL_stashcache doesn't change the resolution behaviour for file |
533 | # handles and package names. | |
534 | SKIP: { | |
b87eccc1 | 535 | skip_if_miniperl('file handles as methods requires loading IO::File', 26); |
6f908f1b NC |
536 | require Fcntl; |
537 | ||
538 | foreach (qw (Count::DATA Count Colour::H1 Color::H1 C3::H1)) { | |
539 | eval qq{ | |
540 | package $_; | |
541 | ||
542 | sub getline { | |
543 | return "method in $_"; | |
544 | } | |
545 | ||
546 | 1; | |
547 | } or die $@; | |
548 | } | |
549 | ||
550 | BEGIN { | |
551 | *The::Count:: = \*Count::; | |
552 | } | |
553 | ||
554 | is(Count::DATA->getline(), 'method in Count::DATA', | |
555 | 'initial resolution is a method'); | |
556 | is(The::Count::DATA->getline(), 'method in Count::DATA', | |
557 | 'initial resolution is a method in aliased classes'); | |
558 | ||
559 | require Count; | |
560 | ||
561 | is(Count::DATA->getline(), "one! ha ha ha\n", 'file handles take priority'); | |
562 | is(The::Count::DATA->getline(), "two! ha ha ha\n", | |
563 | 'file handles take priority in aliased classes'); | |
564 | ||
565 | eval q{close Count::DATA} or die $!; | |
566 | ||
567 | { | |
568 | no warnings 'io'; | |
569 | is(Count::DATA->getline(), undef, | |
570 | "closing a file handle doesn't change object resolution"); | |
571 | is(The::Count::DATA->getline(), undef, | |
572 | "closing a file handle doesn't change object resolution in aliased classes"); | |
573 | } | |
574 | ||
575 | undef *Count::DATA; | |
576 | is(Count::DATA->getline(), 'method in Count::DATA', | |
577 | 'undefining the typeglob does change object resolution'); | |
578 | is(The::Count::DATA->getline(), 'method in Count::DATA', | |
579 | 'undefining the typeglob does change object resolution in aliased classes'); | |
580 | ||
581 | is(Count->getline(), 'method in Count', | |
582 | 'initial resolution is a method'); | |
583 | is(The::Count->getline(), 'method in Count', | |
584 | 'initial resolution is a method in aliased classes'); | |
585 | ||
586 | eval q{ | |
587 | open Count, '<', $INC{'Count.pm'} | |
588 | or die "Can't open $INC{'Count.pm'}: $!"; | |
589 | 1; | |
590 | } or die $@; | |
591 | ||
592 | is(Count->getline(), "# zero! ha ha ha\n", 'file handles take priority'); | |
593 | is(The::Count->getline(), 'method in Count', 'but not in an aliased class'); | |
594 | ||
595 | eval q{close Count} or die $!; | |
596 | ||
597 | { | |
598 | no warnings 'io'; | |
599 | is(Count->getline(), undef, | |
600 | "closing a file handle doesn't change object resolution"); | |
601 | } | |
602 | ||
603 | undef *Count; | |
604 | is(Count->getline(), 'method in Count', | |
605 | 'undefining the typeglob does change object resolution'); | |
606 | ||
607 | open Colour::H1, 'op/method.t' or die $!; | |
608 | while (<Colour::H1>) { | |
609 | last if /^__END__/; | |
610 | } | |
611 | open CLOSED, 'TEST' or die $!; | |
612 | close CLOSED or die $!; | |
613 | ||
614 | my $fh_start = tell Colour::H1; | |
615 | my $data_start = tell DATA; | |
616 | is(Colour::H1->getline(), <DATA>, 'read from a file'); | |
617 | is(Color::H1->getline(), 'method in Color::H1', | |
618 | 'initial resolution is a method'); | |
619 | ||
620 | *Color::H1 = *Colour::H1{IO}; | |
621 | ||
622 | is(Colour::H1->getline(), <DATA>, 'read from a file'); | |
623 | is(Color::H1->getline(), <DATA>, | |
210fdecd | 624 | 'file handles take priority after io-to-typeglob assignment'); |
6f908f1b NC |
625 | |
626 | *Color::H1 = *CLOSED{IO}; | |
627 | { | |
628 | no warnings 'io'; | |
629 | is(Color::H1->getline(), undef, | |
630 | "assigning a closed a file handle doesn't change object resolution"); | |
631 | } | |
632 | ||
633 | undef *Color::H1; | |
634 | is(Color::H1->getline(), 'method in Color::H1', | |
635 | 'undefining the typeglob does change object resolution'); | |
636 | ||
210fdecd FC |
637 | *Color::H1 = *Colour::H1; |
638 | ||
639 | is(Color::H1->getline(), <DATA>, | |
640 | 'file handles take priority after typeglob-to-typeglob assignment'); | |
641 | ||
6f908f1b NC |
642 | seek Colour::H1, $fh_start, Fcntl::SEEK_SET() or die $!; |
643 | seek DATA, $data_start, Fcntl::SEEK_SET() or die $!; | |
644 | ||
645 | is(Colour::H1->getline(), <DATA>, 'read from a file'); | |
646 | is(C3::H1->getline(), 'method in C3::H1', 'intial resolution is a method'); | |
647 | ||
648 | *Copy:: = \*C3::; | |
649 | *C3:: = \*Colour::; | |
650 | ||
651 | is(Colour::H1->getline(), <DATA>, 'read from a file'); | |
652 | is(C3::H1->getline(), <DATA>, | |
653 | 'file handles take priority after stash aliasing'); | |
654 | ||
655 | *C3:: = \*Copy::; | |
656 | ||
657 | is(C3::H1->getline(), 'method in C3::H1', | |
658 | 'restoring the stash returns to a method'); | |
659 | } | |
660 | ||
661 | __END__ | |
662 | #FF9900 | |
663 | #F78C08 | |
664 | #FFA500 | |
665 | #FF4D00 | |
666 | #FC5100 | |
667 | #FF5D00 |