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'; |
20822f61 |
9 | @INC = '../lib'; |
4755096e |
10 | } |
11 | |
b5aabd38 |
12 | print "1..75\n"; |
92d69e20 |
13 | |
14 | @A::ISA = 'B'; |
15 | @B::ISA = 'C'; |
16 | |
17 | sub C::d {"C::d"} |
18 | sub D::d {"D::d"} |
19 | |
20 | my $cnt = 0; |
21 | sub test { |
22 | print "# got `$_[0]', expected `$_[1]'\nnot " unless $_[0] eq $_[1]; |
23 | # print "not " unless shift eq shift; |
b5aabd38 |
24 | print "ok ", ++$cnt; |
25 | print " @_[2..$#_]" if @_ > 2; |
26 | print "\n"; |
92d69e20 |
27 | } |
28 | |
567ce7b1 |
29 | # First, some basic checks of method-calling syntax: |
30 | $obj = bless [], "Pack"; |
31 | sub Pack::method { shift; join(",", "method", @_) } |
32 | $mname = "method"; |
33 | |
34 | test(Pack->method("a","b","c"), "method,a,b,c"); |
35 | test(Pack->$mname("a","b","c"), "method,a,b,c"); |
36 | test(method Pack ("a","b","c"), "method,a,b,c"); |
37 | test((method Pack "a","b","c"), "method,a,b,c"); |
38 | |
39 | test(Pack->method(), "method"); |
40 | test(Pack->$mname(), "method"); |
41 | test(method Pack (), "method"); |
42 | test(Pack->method, "method"); |
43 | test(Pack->$mname, "method"); |
44 | test(method Pack, "method"); |
45 | |
46 | test($obj->method("a","b","c"), "method,a,b,c"); |
47 | test($obj->$mname("a","b","c"), "method,a,b,c"); |
48 | test((method $obj ("a","b","c")), "method,a,b,c"); |
49 | test((method $obj "a","b","c"), "method,a,b,c"); |
145eb477 |
50 | |
51 | test($obj->method(0), "method,0"); |
52 | test($obj->method(1), "method,1"); |
567ce7b1 |
53 | |
54 | test($obj->method(), "method"); |
55 | test($obj->$mname(), "method"); |
56 | test((method $obj ()), "method"); |
57 | test($obj->method, "method"); |
58 | test($obj->$mname, "method"); |
59 | test(method $obj, "method"); |
60 | |
92d69e20 |
61 | test( A->d, "C::d"); # Update hash table; |
62 | |
63 | *B::d = \&D::d; # Import now. |
64 | test (A->d, "D::d"); # Update hash table; |
65 | |
44a8e56a |
66 | { |
fb73857a |
67 | local @A::ISA = qw(C); # Update hash table with split() assignment |
68 | test (A->d, "C::d"); |
69 | $#A::ISA = -1; |
70 | test (eval { A->d } || "fail", "fail"); |
71 | } |
72 | test (A->d, "D::d"); |
73 | |
74 | { |
44a8e56a |
75 | local *B::d; |
76 | eval 'sub B::d {"B::d1"}'; # Import now. |
77 | test (A->d, "B::d1"); # Update hash table; |
78 | undef &B::d; |
79 | test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); |
80 | } |
92d69e20 |
81 | |
44a8e56a |
82 | test (A->d, "D::d"); # Back to previous state |
92d69e20 |
83 | |
84 | eval 'sub B::d {"B::d2"}'; # Import now. |
85 | test (A->d, "B::d2"); # Update hash table; |
86 | |
87 | # What follows is hardly guarantied to work, since the names in scripts |
88 | # are already linked to "pruned" globs. Say, `undef &B::d' if it were |
89 | # after `delete $B::{d}; sub B::d {}' would reach an old subroutine. |
90 | |
91 | undef &B::d; |
92 | delete $B::{d}; |
93 | test (A->d, "C::d"); # Update hash table; |
94 | |
95 | eval 'sub B::d {"B::d3"}'; # Import now. |
96 | test (A->d, "B::d3"); # Update hash table; |
97 | |
98 | delete $B::{d}; |
99 | *dummy::dummy = sub {}; # Mark as updated |
100 | test (A->d, "C::d"); |
101 | |
102 | eval 'sub B::d {"B::d4"}'; # Import now. |
103 | test (A->d, "B::d4"); # Update hash table; |
104 | |
105 | delete $B::{d}; # Should work without any help too |
106 | test (A->d, "C::d"); |
107 | |
fae75791 |
108 | { |
109 | local *C::d; |
110 | test (eval { A->d } || "nope", "nope"); |
111 | } |
112 | test (A->d, "C::d"); |
113 | |
44a8e56a |
114 | *A::x = *A::d; # See if cache incorrectly follows synonyms |
115 | A->d; |
116 | test (eval { A->x } || "nope", "nope"); |
117 | |
92d69e20 |
118 | eval <<'EOF'; |
119 | sub C::e; |
09280a33 |
120 | BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg |
92d69e20 |
121 | sub Y::f; |
122 | $counter = 0; |
123 | |
54310121 |
124 | @X::ISA = 'Y'; |
dc848c6f |
125 | @Y::ISA = 'B'; |
92d69e20 |
126 | |
127 | sub B::AUTOLOAD { |
128 | my $c = ++$counter; |
129 | my $method = $B::AUTOLOAD; |
09280a33 |
130 | my $msg = "B: In $method, $c"; |
131 | eval "sub $method { \$msg }"; |
132 | goto &$method; |
92d69e20 |
133 | } |
134 | sub C::AUTOLOAD { |
135 | my $c = ++$counter; |
136 | my $method = $C::AUTOLOAD; |
09280a33 |
137 | my $msg = "C: In $method, $c"; |
138 | eval "sub $method { \$msg }"; |
139 | goto &$method; |
92d69e20 |
140 | } |
141 | EOF |
142 | |
143 | test(A->e(), "C: In C::e, 1"); # We get a correct autoload |
144 | test(A->e(), "C: In C::e, 1"); # Which sticks |
145 | |
146 | test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top |
147 | test(A->ee(), "B: In A::ee, 2"); # Which sticks |
148 | |
149 | test(Y->f(), "B: In Y::f, 3"); # We vivify a correct method |
150 | test(Y->f(), "B: In Y::f, 3"); # Which sticks |
151 | |
152 | # This test is not intended to be reasonable. It is here just to let you |
153 | # know that you broke some old construction. Feel free to rewrite the test |
154 | # if your patch breaks it. |
155 | |
156 | *B::AUTOLOAD = sub { |
157 | my $c = ++$counter; |
44a8e56a |
158 | my $method = $AUTOLOAD; |
159 | *$AUTOLOAD = sub { "new B: In $method, $c" }; |
160 | goto &$AUTOLOAD; |
92d69e20 |
161 | }; |
162 | |
163 | test(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload |
164 | test(A->eee(), "new B: In A::eee, 4"); # Which sticks |
fb73857a |
165 | |
166 | # this test added due to bug discovery |
6051dbdb |
167 | test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); |
f6ec51f7 |
168 | |
169 | # test that failed subroutine calls don't affect method calls |
170 | { |
171 | package A1; |
172 | sub foo { "foo" } |
173 | package A2; |
174 | @ISA = 'A1'; |
175 | package main; |
176 | test(A2->foo(), "foo"); |
177 | test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); |
178 | test(A2->foo(), "foo"); |
179 | } |
c1899e02 |
180 | |
af09ea45 |
181 | ## This test was totally misguided. It passed before only because the |
182 | ## code to determine if a package was loaded used to look for the hash |
183 | ## %Foo::Bar instead of the package Foo::Bar:: -- and Config.pm just |
184 | ## happens to export %Config. |
185 | # { |
186 | # test(do { use Config; eval 'Config->foo()'; |
187 | # $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); |
188 | # test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; |
189 | # $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); |
190 | # } |
191 | |
192 | |
193 | # test error messages if method loading fails |
194 | test(do { eval '$e = bless {}, "E::A"; E::A->foo()'; |
195 | $@ =~ /^\QCan't locate object method "foo" via package "E::A" at/ ? 1 : $@}, 1); |
196 | test(do { eval '$e = bless {}, "E::B"; $e->foo()'; |
197 | $@ =~ /^\QCan't locate object method "foo" via package "E::B" at/ ? 1 : $@}, 1); |
198 | test(do { eval 'E::C->foo()'; |
199 | $@ =~ /^\QCan't locate object method "foo" via package "E::C" (perhaps / ? 1 : $@}, 1); |
200 | |
201 | test(do { eval 'UNIVERSAL->E::D::foo()'; |
202 | $@ =~ /^\QCan't locate object method "foo" via package "E::D" (perhaps / ? 1 : $@}, 1); |
203 | test(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::E::foo()'; |
204 | $@ =~ /^\QCan't locate object method "foo" via package "E::E" (perhaps / ? 1 : $@}, 1); |
205 | |
206 | $e = bless {}, "E::F"; # force package to exist |
207 | test(do { eval 'UNIVERSAL->E::F::foo()'; |
208 | $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1); |
209 | test(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()'; |
210 | $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1); |
211 | |
212 | # TODO: we need some tests for the SUPER:: pseudoclass |
213 | |
214 | # failed method call or UNIVERSAL::can() should not autovivify packages |
215 | test( $::{"Foo::"} || "none", "none"); # sanity check 1 |
216 | test( $::{"Foo::"} || "none", "none"); # sanity check 2 |
c1899e02 |
217 | |
af09ea45 |
218 | test( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" ); |
219 | test( $::{"Foo::"} || "none", "none"); # still missing? |
220 | |
221 | test( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" ); |
222 | test( $::{"Foo::"} || "none", "none"); # still missing? |
223 | |
224 | test( Foo->can("boogie") ? "yes":"no", "no" ); |
225 | test( $::{"Foo::"} || "none", "none"); # still missing? |
226 | |
227 | test( eval 'Foo->boogie(); 1' ? "yes":"no", "no" ); |
228 | test( $::{"Foo::"} || "none", "none"); # still missing? |
229 | |
230 | test(do { eval 'Foo->boogie()'; |
231 | $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1); |
232 | |
233 | eval 'sub Foo::boogie { "yes, sir!" }'; |
234 | test( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now |
235 | test( Foo->boogie(), "yes, sir!"); |
236 | |
b5aabd38 |
237 | # Some simpleminded tests for the SUPER:: pseudoclass. |
238 | # Note that, right now, SUPER:: seems to start looking in the package |
239 | # it was compiled in, rather than in the class it was called in. |
240 | # Which is wrong. Hence the two TODO tests. |
241 | package Parent; |
242 | |
243 | sub foo { 1 }; |
244 | |
245 | package Child; |
246 | |
247 | @Child::ISA = 'Parent'; |
248 | |
249 | sub child_foo { |
250 | my $self = shift; |
251 | $self->SUPER::foo; |
252 | } |
253 | |
254 | package main; |
255 | |
256 | sub Child::main_foo { $_[0]->SUPER::foo } |
257 | |
258 | *Child::late_foo = sub { $_[0]->SUPER::foo }; |
259 | |
260 | |
261 | test( scalar(eval {Child->child_foo}), 1 ); |
262 | test( scalar(eval {Child->main_foo}), 1, "# TODO SUPER:: non intuitive"); |
263 | test( scalar(eval {Child->late_foo}), 1, "# TODO SUPER:: non intuitive"); |
264 | |
af09ea45 |
265 | # TODO: universal.t should test NoSuchPackage->isa()/can() |
c1899e02 |
266 | |
f0670693 |
267 | # This is actually testing parsing of indirect objects and undefined subs |
268 | # print foo("bar") where foo does not exist is not an indirect object. |
269 | # print foo "bar" where foo does not exist is an indirect object. |
270 | eval { sub AUTOLOAD { "ok ", shift, "\n"; } }; |
271 | print nonsuch(++$cnt); |
af09ea45 |
272 | |
273 | print "# $cnt tests completed\n"; |