Commit | Line | Data |
92d69e20 |
1 | #!./perl |
2 | |
3 | # |
4 | # test method calls and autoloading. |
5 | # |
6 | |
4755096e |
7 | BEGIN { |
8 | chdir 't' if -d 't'; |
6dc4e5ce |
9 | @INC = qw(. ../lib); |
10 | require "test.pl"; |
4755096e |
11 | } |
12 | |
0dae17bd |
13 | print "1..78\n"; |
92d69e20 |
14 | |
15 | @A::ISA = 'B'; |
16 | @B::ISA = 'C'; |
17 | |
18 | sub C::d {"C::d"} |
19 | sub D::d {"D::d"} |
20 | |
567ce7b1 |
21 | # First, some basic checks of method-calling syntax: |
22 | $obj = bless [], "Pack"; |
23 | sub Pack::method { shift; join(",", "method", @_) } |
24 | $mname = "method"; |
25 | |
6dc4e5ce |
26 | is(Pack->method("a","b","c"), "method,a,b,c"); |
27 | is(Pack->$mname("a","b","c"), "method,a,b,c"); |
28 | is(method Pack ("a","b","c"), "method,a,b,c"); |
29 | is((method Pack "a","b","c"), "method,a,b,c"); |
567ce7b1 |
30 | |
6dc4e5ce |
31 | is(Pack->method(), "method"); |
32 | is(Pack->$mname(), "method"); |
33 | is(method Pack (), "method"); |
34 | is(Pack->method, "method"); |
35 | is(Pack->$mname, "method"); |
36 | is(method Pack, "method"); |
567ce7b1 |
37 | |
6dc4e5ce |
38 | is($obj->method("a","b","c"), "method,a,b,c"); |
39 | is($obj->$mname("a","b","c"), "method,a,b,c"); |
40 | is((method $obj ("a","b","c")), "method,a,b,c"); |
41 | is((method $obj "a","b","c"), "method,a,b,c"); |
145eb477 |
42 | |
6dc4e5ce |
43 | is($obj->method(0), "method,0"); |
44 | is($obj->method(1), "method,1"); |
567ce7b1 |
45 | |
6dc4e5ce |
46 | is($obj->method(), "method"); |
47 | is($obj->$mname(), "method"); |
48 | is((method $obj ()), "method"); |
49 | is($obj->method, "method"); |
50 | is($obj->$mname, "method"); |
51 | is(method $obj, "method"); |
567ce7b1 |
52 | |
6dc4e5ce |
53 | is( A->d, "C::d"); # Update hash table; |
92d69e20 |
54 | |
55 | *B::d = \&D::d; # Import now. |
6dc4e5ce |
56 | is(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 |
64 | is(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 |
74 | is(A->d, "D::d"); # Back to previous state |
92d69e20 |
75 | |
76 | eval 'sub B::d {"B::d2"}'; # Import now. |
6dc4e5ce |
77 | is(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 | |
83 | undef &B::d; |
84 | delete $B::{d}; |
6dc4e5ce |
85 | is(A->d, "C::d"); # Update hash table; |
92d69e20 |
86 | |
87 | eval 'sub B::d {"B::d3"}'; # Import now. |
6dc4e5ce |
88 | is(A->d, "B::d3"); # Update hash table; |
92d69e20 |
89 | |
90 | delete $B::{d}; |
91 | *dummy::dummy = sub {}; # Mark as updated |
6dc4e5ce |
92 | is(A->d, "C::d"); |
92d69e20 |
93 | |
94 | eval 'sub B::d {"B::d4"}'; # Import now. |
6dc4e5ce |
95 | is(A->d, "B::d4"); # Update hash table; |
92d69e20 |
96 | |
97 | delete $B::{d}; # Should work without any help too |
6dc4e5ce |
98 | is(A->d, "C::d"); |
92d69e20 |
99 | |
fae75791 |
100 | { |
101 | local *C::d; |
6dc4e5ce |
102 | is(eval { A->d } || "nope", "nope"); |
fae75791 |
103 | } |
6dc4e5ce |
104 | is(A->d, "C::d"); |
fae75791 |
105 | |
44a8e56a |
106 | *A::x = *A::d; # See if cache incorrectly follows synonyms |
107 | A->d; |
6dc4e5ce |
108 | is(eval { A->x } || "nope", "nope"); |
44a8e56a |
109 | |
92d69e20 |
110 | eval <<'EOF'; |
111 | sub C::e; |
09280a33 |
112 | BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg |
92d69e20 |
113 | sub Y::f; |
114 | $counter = 0; |
115 | |
54310121 |
116 | @X::ISA = 'Y'; |
dc848c6f |
117 | @Y::ISA = 'B'; |
92d69e20 |
118 | |
119 | sub 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 | } |
126 | sub 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 | } |
133 | EOF |
134 | |
6dc4e5ce |
135 | is(A->e(), "C: In C::e, 1"); # We get a correct autoload |
136 | is(A->e(), "C: In C::e, 1"); # Which sticks |
92d69e20 |
137 | |
6dc4e5ce |
138 | is(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top |
139 | is(A->ee(), "B: In A::ee, 2"); # Which sticks |
92d69e20 |
140 | |
6dc4e5ce |
141 | is(Y->f(), "B: In Y::f, 3"); # We vivify a correct method |
142 | is(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 |
155 | is(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload |
156 | is(A->eee(), "new B: In A::eee, 4"); # Which sticks |
fb73857a |
157 | |
158 | # this test added due to bug discovery |
6dc4e5ce |
159 | is(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 |
186 | is(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 |
188 | is(do { eval '$e = bless {}, "E::B"; $e->foo()'; |
af09ea45 |
189 | $@ =~ /^\QCan't locate object method "foo" via package "E::B" at/ ? 1 : $@}, 1); |
6dc4e5ce |
190 | is(do { eval 'E::C->foo()'; |
af09ea45 |
191 | $@ =~ /^\QCan't locate object method "foo" via package "E::C" (perhaps / ? 1 : $@}, 1); |
192 | |
6dc4e5ce |
193 | is(do { eval 'UNIVERSAL->E::D::foo()'; |
af09ea45 |
194 | $@ =~ /^\QCan't locate object method "foo" via package "E::D" (perhaps / ? 1 : $@}, 1); |
6dc4e5ce |
195 | is(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 |
199 | is(do { eval 'UNIVERSAL->E::F::foo()'; |
af09ea45 |
200 | $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1); |
6dc4e5ce |
201 | is(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 |
207 | is( $::{"Foo::"} || "none", "none"); # sanity check 1 |
208 | is( $::{"Foo::"} || "none", "none"); # sanity check 2 |
c1899e02 |
209 | |
6dc4e5ce |
210 | is( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" ); |
211 | is( $::{"Foo::"} || "none", "none"); # still missing? |
af09ea45 |
212 | |
6dc4e5ce |
213 | is( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" ); |
214 | is( $::{"Foo::"} || "none", "none"); # still missing? |
af09ea45 |
215 | |
6dc4e5ce |
216 | is( Foo->can("boogie") ? "yes":"no", "no" ); |
217 | is( $::{"Foo::"} || "none", "none"); # still missing? |
af09ea45 |
218 | |
6dc4e5ce |
219 | is( eval 'Foo->boogie(); 1' ? "yes":"no", "no" ); |
220 | is( $::{"Foo::"} || "none", "none"); # still missing? |
af09ea45 |
221 | |
6dc4e5ce |
222 | is(do { eval 'Foo->boogie()'; |
af09ea45 |
223 | $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1); |
224 | |
225 | eval 'sub Foo::boogie { "yes, sir!" }'; |
6dc4e5ce |
226 | is( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now |
227 | is( 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 |
234 | eval 'sub AUTOLOAD { "ok ", shift, "\n"; }'; |
6dc4e5ce |
235 | ok(1); |
af09ea45 |
236 | |
a397c3d9 |
237 | # Bug ID 20010902.002 |
6dc4e5ce |
238 | is( |
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 | |
264 | package main; |
265 | our @X; |
266 | package Amajor; |
267 | sub test { |
268 | push @main::X, 'Amajor', @_; |
269 | } |
270 | package Bminor; |
271 | use base qw(Amajor); |
272 | package main; |
273 | sub Bminor::test { |
274 | $_[0]->Bminor::SUPER::test('x', 'y'); |
275 | push @main::X, 'Bminor', @_; |
276 | } |
277 | Bminor->test('y', 'z'); |
278 | is("@X", "Amajor Bminor x y Bminor Bminor y z"); |
279 | |
0dae17bd |
280 | package main; |
281 | for my $meth (['Bar', 'Foo::Bar'], |
282 | ['SUPER::Bar', 'main::SUPER::Bar'], |
283 | ['Xyz::SUPER::Bar', 'Xyz::SUPER::Bar']) |
284 | { |
285 | fresh_perl_is(<<EOT, |
286 | package UNIVERSAL; sub AUTOLOAD { my \$c = shift; print "\$c \$AUTOLOAD\\n" } |
63c6dcc1 |
287 | sub DESTROY {} # IO object destructor called in MacOS, because of Mac::err |
0dae17bd |
288 | package Xyz; |
289 | package main; Foo->$meth->[0](); |
290 | EOT |
291 | "Foo $meth->[1]", |
292 | { switches => [ '-w' ] }, |
293 | "check if UNIVERSAL::AUTOLOAD works", |
294 | ); |
295 | } |