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