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'; | |
2e59934f | 9 | @INC = qw(. ../lib lib ../dist/base/lib); |
1ae3d757 | 10 | require "./test.pl"; |
4755096e GS |
11 | } |
12 | ||
9bfdb36e NC |
13 | use strict; |
14 | no warnings 'once'; | |
15 | ||
7db8c4f1 | 16 | plan(tests => 150); |
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 | |
f6ec51f7 GS |
173 | # test that failed subroutine calls don't affect method calls |
174 | { | |
175 | package A1; | |
176 | sub foo { "foo" } | |
177 | package A2; | |
9bfdb36e | 178 | @A2::ISA = 'A1'; |
f6ec51f7 | 179 | package main; |
6dc4e5ce JH |
180 | is(A2->foo(), "foo"); |
181 | is(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); | |
182 | is(A2->foo(), "foo"); | |
f6ec51f7 | 183 | } |
c1899e02 | 184 | |
af09ea45 IK |
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. | |
189 | # { | |
6dc4e5ce | 190 | # is(do { use Config; eval 'Config->foo()'; |
af09ea45 | 191 | # $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); |
6dc4e5ce | 192 | # is(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; |
af09ea45 IK |
193 | # $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); |
194 | # } | |
195 | ||
af09ea45 | 196 | # test error messages if method loading fails |
9bfdb36e NC |
197 | my $e; |
198 | ||
2f907243 NC |
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/); | |
203 | eval 'E::C->foo()'; | |
204 | like ($@, qr/^\QCan't locate object method "foo" via package "E::C" (perhaps /); | |
205 | ||
206 | eval 'UNIVERSAL->E::D::foo()'; | |
207 | like ($@, qr/^\QCan't locate object method "foo" via package "E::D" (perhaps /); | |
9bfdb36e | 208 | eval 'my $e = bless {}, "UNIVERSAL"; $e->E::E::foo()'; |
2f907243 | 209 | like ($@, qr/^\QCan't locate object method "foo" via package "E::E" (perhaps /); |
af09ea45 IK |
210 | |
211 | $e = bless {}, "E::F"; # force package to exist | |
2f907243 NC |
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/); | |
af09ea45 | 216 | |
697efb9b FC |
217 | # SUPER:: pseudoclass |
218 | @Saab::ISA = "Souper"; | |
219 | sub Souper::method { @_ } | |
220 | @OtherSaab::ISA = "OtherSouper"; | |
221 | sub OtherSouper::method { "Isidore Ropen, Draft Manager" } | |
222 | { | |
223 | my $o = bless [], "Saab"; | |
224 | package 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"; | |
236 | } | |
3c104e59 FC |
237 | () = *SUPER::; |
238 | { | |
239 | local our @ISA = "Souper"; | |
240 | is eval { (main->SUPER::method)[0] }, 'main', | |
241 | 'Mentioning *SUPER:: does not stop ->SUPER from working in main'; | |
242 | } | |
0308a534 FC |
243 | { |
244 | BEGIN { | |
245 | *Mover:: = *Mover2::; | |
246 | *Mover2:: = *foo; | |
247 | } | |
248 | package Mover; | |
249 | no strict; | |
250 | # Not our(@ISA), because the bug we are testing for interacts with an | |
251 | # our() bug that cancels this bug out. | |
252 | @ISA = 'door'; | |
253 | sub door::dohtem { 'dohtem' } | |
254 | ::is eval { Mover->SUPER::dohtem; }, 'dohtem', | |
255 | 'SUPER inside moved package'; | |
37b0b3b2 FC |
256 | undef *door::dohtem; |
257 | *door::dohtem = sub { 'method' }; | |
258 | ::is eval { Mover->SUPER::dohtem; }, 'method', | |
259 | 'SUPER inside moved package respects method changes'; | |
0308a534 | 260 | } |
af09ea45 | 261 | |
257dc59d FC |
262 | package foo120694 { |
263 | BEGIN { our @ISA = qw(bar120694) } | |
264 | ||
265 | sub AUTOLOAD { | |
266 | my $self = shift; | |
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(@_); | |
272 | } | |
273 | } | |
274 | package bar120694 { | |
275 | sub AUTOLOAD { | |
276 | return "xyzzy"; | |
277 | } | |
278 | } | |
279 | is bless( [] => "foo120694" )->plugh, 'xyzzy', | |
280 | '->SUPER::method autoloading uses parent of current pkg'; | |
281 | ||
282 | ||
af09ea45 | 283 | # failed method call or UNIVERSAL::can() should not autovivify packages |
6dc4e5ce JH |
284 | is( $::{"Foo::"} || "none", "none"); # sanity check 1 |
285 | is( $::{"Foo::"} || "none", "none"); # sanity check 2 | |
c1899e02 | 286 | |
6dc4e5ce JH |
287 | is( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" ); |
288 | is( $::{"Foo::"} || "none", "none"); # still missing? | |
af09ea45 | 289 | |
6dc4e5ce JH |
290 | is( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" ); |
291 | is( $::{"Foo::"} || "none", "none"); # still missing? | |
af09ea45 | 292 | |
6dc4e5ce JH |
293 | is( Foo->can("boogie") ? "yes":"no", "no" ); |
294 | is( $::{"Foo::"} || "none", "none"); # still missing? | |
af09ea45 | 295 | |
6dc4e5ce JH |
296 | is( eval 'Foo->boogie(); 1' ? "yes":"no", "no" ); |
297 | is( $::{"Foo::"} || "none", "none"); # still missing? | |
af09ea45 | 298 | |
6dc4e5ce | 299 | is(do { eval 'Foo->boogie()'; |
af09ea45 IK |
300 | $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1); |
301 | ||
302 | eval 'sub Foo::boogie { "yes, sir!" }'; | |
6dc4e5ce JH |
303 | is( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now |
304 | is( Foo->boogie(), "yes, sir!"); | |
af09ea45 IK |
305 | |
306 | # TODO: universal.t should test NoSuchPackage->isa()/can() | |
c1899e02 | 307 | |
f0670693 SC |
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. | |
84251760 | 311 | eval 'sub AUTOLOAD { "ok ", shift, "\n"; }'; |
6dc4e5ce | 312 | ok(1); |
af09ea45 | 313 | |
a397c3d9 | 314 | # Bug ID 20010902.002 |
6dc4e5ce | 315 | is( |
a397c3d9 | 316 | eval q[ |
9bfdb36e | 317 | my $x = 'x'; # Lexical or package variable, 5.6.1 panics. |
a397c3d9 RGS |
318 | sub Foo::x : lvalue { $x } |
319 | Foo->$x = 'ok'; | |
320 | ] || $@, 'ok' | |
321 | ); | |
322 | ||
3ad83ce7 AMS |
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> | |
326 | ||
327 | { | |
328 | use warnings; | |
329 | my $w = ''; | |
330 | local $SIG{__WARN__} = sub { $w = $_[0] }; | |
331 | ||
332 | sub AutoDest::Base::AUTOLOAD {} | |
333 | @AutoDest::ISA = qw(AutoDest::Base); | |
334 | { my $x = bless {}, 'AutoDest'; } | |
335 | $w =~ s/\n//g; | |
6dc4e5ce | 336 | is($w, ''); |
3ad83ce7 AMS |
337 | } |
338 | ||
e189a56d IK |
339 | # [ID 20020305.025] PACKAGE::SUPER doesn't work anymore |
340 | ||
341 | package main; | |
342 | our @X; | |
343 | package Amajor; | |
344 | sub test { | |
345 | push @main::X, 'Amajor', @_; | |
346 | } | |
347 | package Bminor; | |
348 | use base qw(Amajor); | |
349 | package main; | |
350 | sub Bminor::test { | |
351 | $_[0]->Bminor::SUPER::test('x', 'y'); | |
352 | push @main::X, 'Bminor', @_; | |
353 | } | |
354 | Bminor->test('y', 'z'); | |
355 | is("@X", "Amajor Bminor x y Bminor Bminor y z"); | |
356 | ||
0dae17bd GS |
357 | package main; |
358 | for my $meth (['Bar', 'Foo::Bar'], | |
359 | ['SUPER::Bar', 'main::SUPER::Bar'], | |
360 | ['Xyz::SUPER::Bar', 'Xyz::SUPER::Bar']) | |
361 | { | |
362 | fresh_perl_is(<<EOT, | |
363 | package UNIVERSAL; sub AUTOLOAD { my \$c = shift; print "\$c \$AUTOLOAD\\n" } | |
000814da | 364 | sub DESTROY {} # prevent AUTOLOAD being called on DESTROY |
0dae17bd GS |
365 | package Xyz; |
366 | package main; Foo->$meth->[0](); | |
367 | EOT | |
368 | "Foo $meth->[1]", | |
369 | { switches => [ '-w' ] }, | |
370 | "check if UNIVERSAL::AUTOLOAD works", | |
371 | ); | |
372 | } | |
1f15e670 NT |
373 | |
374 | # Test for #71952: crash when looking for a nonexistent destructor | |
375 | # Regression introduced by fbb3ee5af3d4 | |
376 | { | |
377 | fresh_perl_is(<<'EOT', | |
378 | sub M::DESTROY; bless {}, "M" ; print "survived\n"; | |
379 | EOT | |
380 | "survived", | |
381 | {}, | |
382 | "no crash with a declared but missing DESTROY method" | |
383 | ); | |
384 | } | |
385 | ||
da6b625f FC |
386 | # Test for calling a method on a packag name return by a magic variable |
387 | sub TIESCALAR{bless[]} | |
388 | sub FETCH{"main"} | |
389 | my $kalled; | |
390 | sub bolgy { ++$kalled; } | |
391 | tie my $a, ""; | |
392 | $a->bolgy; | |
393 | is $kalled, 1, 'calling a class method via a magic variable'; | |
f937af42 BF |
394 | |
395 | { | |
396 | package NulTest; | |
397 | sub method { 1 } | |
398 | ||
399 | package main; | |
400 | eval { | |
401 | NulTest->${ \"method\0Whoops" }; | |
402 | }; | |
403 | like $@, qr/Can't locate object method "method\0Whoops" via package "NulTest" at/, | |
404 | "method lookup is nul-clean"; | |
405 | ||
406 | *NulTest::AUTOLOAD = sub { our $AUTOLOAD; return $AUTOLOAD }; | |
407 | ||
aaa63dae | 408 | like(NulTest->${ \"nul\0test" }, qr/nul\0test/, "AUTOLOAD is nul-clean"); |
f937af42 | 409 | } |
2a0f5ef0 BF |
410 | |
411 | ||
412 | { | |
413 | fresh_perl_is( | |
414 | q! sub T::DESTROY { $x = $_[0]; } bless [], "T";!, | |
415 | "DESTROY created new reference to dead object 'T' during global destruction.", | |
416 | {}, | |
417 | "DESTROY creating a new reference to the object generates a warning." | |
418 | ); | |
419 | } | |
71481574 FC |
420 | |
421 | # [perl #43663] | |
422 | { | |
423 | $::{"Just"} = \1; | |
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'; | |
427 | } | |
0865059d FC |
428 | |
429 | # [perl #109264] | |
430 | { | |
431 | no strict 'vars'; | |
432 | sub bliggles { 1 } | |
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'; | |
446 | } | |
544b72e2 BF |
447 | |
448 | { | |
449 | # AUTOLOAD and DESTROY can be declared without a leading sub, | |
450 | # like BEGIN and friends. | |
451 | package NoSub; | |
452 | ||
453 | eval 'AUTOLOAD { our $AUTOLOAD; return $AUTOLOAD }'; | |
454 | ::ok( !$@, "AUTOLOAD without a leading sub is legal" ); | |
455 | ||
456 | eval "DESTROY { ::pass( q!DESTROY without a leading sub is legal and gets called! ) }"; | |
457 | { | |
458 | ::ok( NoSub->can("AUTOLOAD"), "...and sets up an AUTOLOAD normally" ); | |
459 | ::is( eval { NoSub->bluh }, "NoSub::bluh", "...which works as expected" ); | |
460 | } | |
461 | { bless {}, "NoSub"; } | |
462 | } | |
f226e9be | 463 | |
f05081b8 TC |
464 | { |
465 | # [perl #124387] | |
f05081b8 TC |
466 | my $autoloaded; |
467 | package AutoloadDestroy; | |
468 | sub AUTOLOAD { $autoloaded = 1 } | |
469 | package main; | |
470 | bless {}, "AutoloadDestroy"; | |
471 | ok($autoloaded, "AUTOLOAD called for DESTROY"); | |
7db8c4f1 TC |
472 | |
473 | # 127494 - AUTOLOAD for DESTROY was called without setting $AUTOLOAD | |
474 | local $::TODO = "caching of AUTOLOAD for DESTROY didn't set \$AUTOLOAD"; | |
475 | my %methods; | |
476 | package AutoloadDestroy2; | |
477 | sub AUTOLOAD { | |
478 | our $AUTOLOAD; | |
479 | (my $method = $AUTOLOAD) =~ s/.*:://; | |
480 | ++$methods{$method}; | |
481 | } | |
482 | package main; | |
483 | # this cached AUTOLOAD as the DESTROY method | |
484 | bless {}, "AutoloadDestroy2"; | |
485 | %methods = (); | |
486 | my $o = bless {}, "AutoloadDestroy2"; | |
487 | # this sets $AUTOLOAD to "AutoloadDestroy2::foo" | |
488 | $o->foo; | |
489 | # this would call AUTOLOAD without setting $AUTOLOAD | |
490 | undef $o; | |
491 | ok($methods{DESTROY}, "\$AUTOLOAD set correctly for DESTROY"); | |
f05081b8 TC |
492 | } |
493 | ||
f226e9be FC |
494 | eval { () = 3; new {} }; |
495 | like $@, | |
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 {} }; | |
499 | like $@, | |
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 {} }; | |
503 | like $@, | |
504 | qr/^Can't call method "new" without a package or object reference/, | |
505 | 'Err msg from new{} when stack contains undef'; | |
bfde49d4 FC |
506 | |
507 | package egakacp { | |
508 | our @ISA = 'ASI'; | |
509 | sub ASI::m { shift; "@_" }; | |
510 | my @a = (bless([]), 'arg'); | |
511 | my $r = SUPER::m{@a}; | |
512 | ::is $r, 'arg', 'method{@array}'; | |
513 | $r = SUPER::m{}@a; | |
514 | ::is $r, 'arg', 'method{}@array'; | |
515 | $r = SUPER::m{@a}"b"; | |
516 | ::is $r, 'arg b', 'method{@array}$more_args'; | |
517 | } | |
aae43805 FC |
518 | |
519 | # [perl #114924] SUPER->method | |
520 | @SUPER::ISA = "SUPPER"; | |
521 | sub SUPPER::foo { "supper" } | |
522 | is "SUPER"->foo, 'supper', 'SUPER->method'; | |
7156e69a FC |
523 | |
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'; | |
528 | eval { ""->flomp }; | |
529 | like $@, | |
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!)'; | |
6f908f1b | 535 | |
a77c16f7 FC |
536 | # *foo vs (\*foo) |
537 | sub myclass::squeak { 'eek' } | |
538 | eval { *myclass->squeak }; | |
539 | like $@, | |
540 | qr/^Can't call method "squeak" without a package or object reference/, | |
541 | 'method call on typeglob ignores package'; | |
542 | eval { (\*myclass)->squeak }; | |
543 | like $@, | |
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' } | |
552 | ->($::h{k}); | |
553 | ||
6f908f1b NC |
554 | # Test that PL_stashcache doesn't change the resolution behaviour for file |
555 | # handles and package names. | |
556 | SKIP: { | |
b87eccc1 | 557 | skip_if_miniperl('file handles as methods requires loading IO::File', 26); |
6f908f1b NC |
558 | require Fcntl; |
559 | ||
560 | foreach (qw (Count::DATA Count Colour::H1 Color::H1 C3::H1)) { | |
561 | eval qq{ | |
562 | package $_; | |
563 | ||
564 | sub getline { | |
565 | return "method in $_"; | |
566 | } | |
567 | ||
568 | 1; | |
569 | } or die $@; | |
570 | } | |
571 | ||
572 | BEGIN { | |
573 | *The::Count:: = \*Count::; | |
574 | } | |
575 | ||
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'); | |
580 | ||
581 | require Count; | |
582 | ||
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'); | |
586 | ||
587 | eval q{close Count::DATA} or die $!; | |
588 | ||
589 | { | |
590 | no warnings 'io'; | |
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"); | |
595 | } | |
596 | ||
597 | undef *Count::DATA; | |
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'); | |
602 | ||
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'); | |
607 | ||
608 | eval q{ | |
609 | open Count, '<', $INC{'Count.pm'} | |
610 | or die "Can't open $INC{'Count.pm'}: $!"; | |
611 | 1; | |
612 | } or die $@; | |
613 | ||
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'); | |
616 | ||
617 | eval q{close Count} or die $!; | |
618 | ||
619 | { | |
620 | no warnings 'io'; | |
621 | is(Count->getline(), undef, | |
622 | "closing a file handle doesn't change object resolution"); | |
623 | } | |
624 | ||
625 | undef *Count; | |
626 | is(Count->getline(), 'method in Count', | |
627 | 'undefining the typeglob does change object resolution'); | |
628 | ||
629 | open Colour::H1, 'op/method.t' or die $!; | |
630 | while (<Colour::H1>) { | |
631 | last if /^__END__/; | |
632 | } | |
633 | open CLOSED, 'TEST' or die $!; | |
634 | close CLOSED or die $!; | |
635 | ||
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'); | |
641 | ||
642 | *Color::H1 = *Colour::H1{IO}; | |
643 | ||
644 | is(Colour::H1->getline(), <DATA>, 'read from a file'); | |
645 | is(Color::H1->getline(), <DATA>, | |
210fdecd | 646 | 'file handles take priority after io-to-typeglob assignment'); |
6f908f1b NC |
647 | |
648 | *Color::H1 = *CLOSED{IO}; | |
649 | { | |
650 | no warnings 'io'; | |
651 | is(Color::H1->getline(), undef, | |
652 | "assigning a closed a file handle doesn't change object resolution"); | |
653 | } | |
654 | ||
655 | undef *Color::H1; | |
656 | is(Color::H1->getline(), 'method in Color::H1', | |
657 | 'undefining the typeglob does change object resolution'); | |
658 | ||
210fdecd FC |
659 | *Color::H1 = *Colour::H1; |
660 | ||
661 | is(Color::H1->getline(), <DATA>, | |
662 | 'file handles take priority after typeglob-to-typeglob assignment'); | |
663 | ||
6f908f1b NC |
664 | seek Colour::H1, $fh_start, Fcntl::SEEK_SET() or die $!; |
665 | seek DATA, $data_start, Fcntl::SEEK_SET() or die $!; | |
666 | ||
667 | is(Colour::H1->getline(), <DATA>, 'read from a file'); | |
5c25e937 | 668 | is(C3::H1->getline(), 'method in C3::H1', 'initial resolution is a method'); |
6f908f1b NC |
669 | |
670 | *Copy:: = \*C3::; | |
671 | *C3:: = \*Colour::; | |
672 | ||
673 | is(Colour::H1->getline(), <DATA>, 'read from a file'); | |
674 | is(C3::H1->getline(), <DATA>, | |
675 | 'file handles take priority after stash aliasing'); | |
676 | ||
677 | *C3:: = \*Copy::; | |
678 | ||
679 | is(C3::H1->getline(), 'method in C3::H1', | |
680 | 'restoring the stash returns to a method'); | |
681 | } | |
682 | ||
b99dfd93 DM |
683 | # RT #123619 constant class name should be read-only |
684 | ||
685 | { | |
686 | sub RT123619::f { chop $_[0] } | |
687 | eval { 'RT123619'->f(); }; | |
688 | like ($@, qr/Modification of a read-only value attempted/, 'RT #123619'); | |
689 | } | |
690 | ||
0cd52e23 TC |
691 | { |
692 | # RT #126042 &{1==1} * &{1==1} would crash | |
693 | ||
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. | |
700 | ||
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"); | |
706 | } | |
707 | ||
6f908f1b NC |
708 | __END__ |
709 | #FF9900 | |
710 | #F78C08 | |
711 | #FFA500 | |
712 | #FF4D00 | |
713 | #FC5100 | |
714 | #FF5D00 |