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