Suppress a few compilation warnings in pp_hot.c.
[p5sagit/p5-mst-13.2.git] / t / op / method.t
CommitLineData
92d69e20 1#!./perl
2
3#
4# test method calls and autoloading.
5#
6
4755096e 7BEGIN {
8 chdir 't' if -d 't';
6dc4e5ce 9 @INC = qw(. ../lib);
10 require "test.pl";
4755096e 11}
12
0dae17bd 13print "1..78\n";
92d69e20 14
15@A::ISA = 'B';
16@B::ISA = 'C';
17
18sub C::d {"C::d"}
19sub D::d {"D::d"}
20
567ce7b1 21# First, some basic checks of method-calling syntax:
22$obj = bless [], "Pack";
23sub Pack::method { shift; join(",", "method", @_) }
24$mname = "method";
25
6dc4e5ce 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");
567ce7b1 30
6dc4e5ce 31is(Pack->method(), "method");
32is(Pack->$mname(), "method");
33is(method Pack (), "method");
34is(Pack->method, "method");
35is(Pack->$mname, "method");
36is(method Pack, "method");
567ce7b1 37
6dc4e5ce 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");
145eb477 42
6dc4e5ce 43is($obj->method(0), "method,0");
44is($obj->method(1), "method,1");
567ce7b1 45
6dc4e5ce 46is($obj->method(), "method");
47is($obj->$mname(), "method");
48is((method $obj ()), "method");
49is($obj->method, "method");
50is($obj->$mname, "method");
51is(method $obj, "method");
567ce7b1 52
6dc4e5ce 53is( A->d, "C::d"); # Update hash table;
92d69e20 54
55*B::d = \&D::d; # Import now.
6dc4e5ce 56is(A->d, "D::d"); # Update hash table;
92d69e20 57
44a8e56a 58{
fb73857a 59 local @A::ISA = qw(C); # Update hash table with split() assignment
6dc4e5ce 60 is(A->d, "C::d");
fb73857a 61 $#A::ISA = -1;
6dc4e5ce 62 is(eval { A->d } || "fail", "fail");
fb73857a 63}
6dc4e5ce 64is(A->d, "D::d");
fb73857a 65
66{
44a8e56a 67 local *B::d;
68 eval 'sub B::d {"B::d1"}'; # Import now.
6dc4e5ce 69 is(A->d, "B::d1"); # Update hash table;
44a8e56a 70 undef &B::d;
6dc4e5ce 71 is((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1);
44a8e56a 72}
92d69e20 73
6dc4e5ce 74is(A->d, "D::d"); # Back to previous state
92d69e20 75
76eval 'sub B::d {"B::d2"}'; # Import now.
6dc4e5ce 77is(A->d, "B::d2"); # Update hash table;
92d69e20 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};
6dc4e5ce 85is(A->d, "C::d"); # Update hash table;
92d69e20 86
87eval 'sub B::d {"B::d3"}'; # Import now.
6dc4e5ce 88is(A->d, "B::d3"); # Update hash table;
92d69e20 89
90delete $B::{d};
91*dummy::dummy = sub {}; # Mark as updated
6dc4e5ce 92is(A->d, "C::d");
92d69e20 93
94eval 'sub B::d {"B::d4"}'; # Import now.
6dc4e5ce 95is(A->d, "B::d4"); # Update hash table;
92d69e20 96
97delete $B::{d}; # Should work without any help too
6dc4e5ce 98is(A->d, "C::d");
92d69e20 99
fae75791 100{
101 local *C::d;
6dc4e5ce 102 is(eval { A->d } || "nope", "nope");
fae75791 103}
6dc4e5ce 104is(A->d, "C::d");
fae75791 105
44a8e56a 106*A::x = *A::d; # See if cache incorrectly follows synonyms
107A->d;
6dc4e5ce 108is(eval { A->x } || "nope", "nope");
44a8e56a 109
92d69e20 110eval <<'EOF';
111sub C::e;
09280a33 112BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg
92d69e20 113sub Y::f;
114$counter = 0;
115
54310121 116@X::ISA = 'Y';
dc848c6f 117@Y::ISA = 'B';
92d69e20 118
119sub B::AUTOLOAD {
120 my $c = ++$counter;
121 my $method = $B::AUTOLOAD;
09280a33 122 my $msg = "B: In $method, $c";
123 eval "sub $method { \$msg }";
124 goto &$method;
92d69e20 125}
126sub C::AUTOLOAD {
127 my $c = ++$counter;
128 my $method = $C::AUTOLOAD;
09280a33 129 my $msg = "C: In $method, $c";
130 eval "sub $method { \$msg }";
131 goto &$method;
92d69e20 132}
133EOF
134
6dc4e5ce 135is(A->e(), "C: In C::e, 1"); # We get a correct autoload
136is(A->e(), "C: In C::e, 1"); # Which sticks
92d69e20 137
6dc4e5ce 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
92d69e20 140
6dc4e5ce 141is(Y->f(), "B: In Y::f, 3"); # We vivify a correct method
142is(Y->f(), "B: In Y::f, 3"); # Which sticks
92d69e20 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;
44a8e56a 150 my $method = $AUTOLOAD;
151 *$AUTOLOAD = sub { "new B: In $method, $c" };
152 goto &$AUTOLOAD;
92d69e20 153};
154
6dc4e5ce 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
fb73857a 157
158# this test added due to bug discovery
6dc4e5ce 159is(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined");
f6ec51f7 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;
6dc4e5ce 168 is(A2->foo(), "foo");
169 is(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1);
170 is(A2->foo(), "foo");
f6ec51f7 171}
c1899e02 172
af09ea45 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# {
6dc4e5ce 178# is(do { use Config; eval 'Config->foo()';
af09ea45 179# $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
6dc4e5ce 180# is(do { use Config; eval '$d = bless {}, "Config"; $d->foo()';
af09ea45 181# $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
182# }
183
184
185# test error messages if method loading fails
6dc4e5ce 186is(do { eval '$e = bless {}, "E::A"; E::A->foo()';
af09ea45 187 $@ =~ /^\QCan't locate object method "foo" via package "E::A" at/ ? 1 : $@}, 1);
6dc4e5ce 188is(do { eval '$e = bless {}, "E::B"; $e->foo()';
af09ea45 189 $@ =~ /^\QCan't locate object method "foo" via package "E::B" at/ ? 1 : $@}, 1);
6dc4e5ce 190is(do { eval 'E::C->foo()';
af09ea45 191 $@ =~ /^\QCan't locate object method "foo" via package "E::C" (perhaps / ? 1 : $@}, 1);
192
6dc4e5ce 193is(do { eval 'UNIVERSAL->E::D::foo()';
af09ea45 194 $@ =~ /^\QCan't locate object method "foo" via package "E::D" (perhaps / ? 1 : $@}, 1);
6dc4e5ce 195is(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::E::foo()';
af09ea45 196 $@ =~ /^\QCan't locate object method "foo" via package "E::E" (perhaps / ? 1 : $@}, 1);
197
198$e = bless {}, "E::F"; # force package to exist
6dc4e5ce 199is(do { eval 'UNIVERSAL->E::F::foo()';
af09ea45 200 $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1);
6dc4e5ce 201is(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()';
af09ea45 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
6dc4e5ce 207is( $::{"Foo::"} || "none", "none"); # sanity check 1
208is( $::{"Foo::"} || "none", "none"); # sanity check 2
c1899e02 209
6dc4e5ce 210is( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" );
211is( $::{"Foo::"} || "none", "none"); # still missing?
af09ea45 212
6dc4e5ce 213is( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" );
214is( $::{"Foo::"} || "none", "none"); # still missing?
af09ea45 215
6dc4e5ce 216is( Foo->can("boogie") ? "yes":"no", "no" );
217is( $::{"Foo::"} || "none", "none"); # still missing?
af09ea45 218
6dc4e5ce 219is( eval 'Foo->boogie(); 1' ? "yes":"no", "no" );
220is( $::{"Foo::"} || "none", "none"); # still missing?
af09ea45 221
6dc4e5ce 222is(do { eval 'Foo->boogie()';
af09ea45 223 $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1);
224
225eval 'sub Foo::boogie { "yes, sir!" }';
6dc4e5ce 226is( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now
227is( Foo->boogie(), "yes, sir!");
af09ea45 228
229# TODO: universal.t should test NoSuchPackage->isa()/can()
c1899e02 230
f0670693 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.
84251760 234eval 'sub AUTOLOAD { "ok ", shift, "\n"; }';
6dc4e5ce 235ok(1);
af09ea45 236
a397c3d9 237# Bug ID 20010902.002
6dc4e5ce 238is(
a397c3d9 239 eval q[
240 $x = 'x';
241 sub Foo::x : lvalue { $x }
242 Foo->$x = 'ok';
243 ] || $@, 'ok'
244);
245
3ad83ce7 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;
6dc4e5ce 259 is($w, '');
3ad83ce7 260}
261
e189a56d 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
0dae17bd 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" }
63c6dcc1 287sub DESTROY {} # IO object destructor called in MacOS, because of Mac::err
0dae17bd 288package Xyz;
289package main; Foo->$meth->[0]();
290EOT
291 "Foo $meth->[1]",
292 { switches => [ '-w' ] },
293 "check if UNIVERSAL::AUTOLOAD works",
294 );
295}