Commit | Line | Data |
---|---|---|
92d69e20 IZ |
1 | #!./perl |
2 | ||
3 | # | |
4 | # test method calls and autoloading. | |
5 | # | |
6 | ||
4755096e GS |
7 | BEGIN { |
8 | chdir 't' if -d 't'; | |
20822f61 | 9 | @INC = '../lib'; |
4755096e GS |
10 | } |
11 | ||
f0670693 | 12 | print "1..54\n"; |
92d69e20 IZ |
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; | |
24 | print "ok ", ++$cnt, "\n" | |
25 | } | |
26 | ||
567ce7b1 SM |
27 | # First, some basic checks of method-calling syntax: |
28 | $obj = bless [], "Pack"; | |
29 | sub Pack::method { shift; join(",", "method", @_) } | |
30 | $mname = "method"; | |
31 | ||
32 | test(Pack->method("a","b","c"), "method,a,b,c"); | |
33 | test(Pack->$mname("a","b","c"), "method,a,b,c"); | |
34 | test(method Pack ("a","b","c"), "method,a,b,c"); | |
35 | test((method Pack "a","b","c"), "method,a,b,c"); | |
36 | ||
37 | test(Pack->method(), "method"); | |
38 | test(Pack->$mname(), "method"); | |
39 | test(method Pack (), "method"); | |
40 | test(Pack->method, "method"); | |
41 | test(Pack->$mname, "method"); | |
42 | test(method Pack, "method"); | |
43 | ||
44 | test($obj->method("a","b","c"), "method,a,b,c"); | |
45 | test($obj->$mname("a","b","c"), "method,a,b,c"); | |
46 | test((method $obj ("a","b","c")), "method,a,b,c"); | |
47 | test((method $obj "a","b","c"), "method,a,b,c"); | |
48 | ||
49 | test($obj->method(), "method"); | |
50 | test($obj->$mname(), "method"); | |
51 | test((method $obj ()), "method"); | |
52 | test($obj->method, "method"); | |
53 | test($obj->$mname, "method"); | |
54 | test(method $obj, "method"); | |
55 | ||
92d69e20 IZ |
56 | test( A->d, "C::d"); # Update hash table; |
57 | ||
58 | *B::d = \&D::d; # Import now. | |
59 | test (A->d, "D::d"); # Update hash table; | |
60 | ||
44a8e56a | 61 | { |
fb73857a | 62 | local @A::ISA = qw(C); # Update hash table with split() assignment |
63 | test (A->d, "C::d"); | |
64 | $#A::ISA = -1; | |
65 | test (eval { A->d } || "fail", "fail"); | |
66 | } | |
67 | test (A->d, "D::d"); | |
68 | ||
69 | { | |
44a8e56a | 70 | local *B::d; |
71 | eval 'sub B::d {"B::d1"}'; # Import now. | |
72 | test (A->d, "B::d1"); # Update hash table; | |
73 | undef &B::d; | |
74 | test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); | |
75 | } | |
92d69e20 | 76 | |
44a8e56a | 77 | test (A->d, "D::d"); # Back to previous state |
92d69e20 IZ |
78 | |
79 | eval 'sub B::d {"B::d2"}'; # Import now. | |
80 | test (A->d, "B::d2"); # Update hash table; | |
81 | ||
82 | # What follows is hardly guarantied to work, since the names in scripts | |
83 | # are already linked to "pruned" globs. Say, `undef &B::d' if it were | |
84 | # after `delete $B::{d}; sub B::d {}' would reach an old subroutine. | |
85 | ||
86 | undef &B::d; | |
87 | delete $B::{d}; | |
88 | test (A->d, "C::d"); # Update hash table; | |
89 | ||
90 | eval 'sub B::d {"B::d3"}'; # Import now. | |
91 | test (A->d, "B::d3"); # Update hash table; | |
92 | ||
93 | delete $B::{d}; | |
94 | *dummy::dummy = sub {}; # Mark as updated | |
95 | test (A->d, "C::d"); | |
96 | ||
97 | eval 'sub B::d {"B::d4"}'; # Import now. | |
98 | test (A->d, "B::d4"); # Update hash table; | |
99 | ||
100 | delete $B::{d}; # Should work without any help too | |
101 | test (A->d, "C::d"); | |
102 | ||
fae75791 CS |
103 | { |
104 | local *C::d; | |
105 | test (eval { A->d } || "nope", "nope"); | |
106 | } | |
107 | test (A->d, "C::d"); | |
108 | ||
44a8e56a | 109 | *A::x = *A::d; # See if cache incorrectly follows synonyms |
110 | A->d; | |
111 | test (eval { A->x } || "nope", "nope"); | |
112 | ||
92d69e20 IZ |
113 | eval <<'EOF'; |
114 | sub C::e; | |
09280a33 | 115 | BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg |
92d69e20 IZ |
116 | sub Y::f; |
117 | $counter = 0; | |
118 | ||
54310121 | 119 | @X::ISA = 'Y'; |
dc848c6f | 120 | @Y::ISA = 'B'; |
92d69e20 IZ |
121 | |
122 | sub B::AUTOLOAD { | |
123 | my $c = ++$counter; | |
124 | my $method = $B::AUTOLOAD; | |
09280a33 CS |
125 | my $msg = "B: In $method, $c"; |
126 | eval "sub $method { \$msg }"; | |
127 | goto &$method; | |
92d69e20 IZ |
128 | } |
129 | sub C::AUTOLOAD { | |
130 | my $c = ++$counter; | |
131 | my $method = $C::AUTOLOAD; | |
09280a33 CS |
132 | my $msg = "C: In $method, $c"; |
133 | eval "sub $method { \$msg }"; | |
134 | goto &$method; | |
92d69e20 IZ |
135 | } |
136 | EOF | |
137 | ||
138 | test(A->e(), "C: In C::e, 1"); # We get a correct autoload | |
139 | test(A->e(), "C: In C::e, 1"); # Which sticks | |
140 | ||
141 | test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top | |
142 | test(A->ee(), "B: In A::ee, 2"); # Which sticks | |
143 | ||
144 | test(Y->f(), "B: In Y::f, 3"); # We vivify a correct method | |
145 | test(Y->f(), "B: In Y::f, 3"); # Which sticks | |
146 | ||
147 | # This test is not intended to be reasonable. It is here just to let you | |
148 | # know that you broke some old construction. Feel free to rewrite the test | |
149 | # if your patch breaks it. | |
150 | ||
151 | *B::AUTOLOAD = sub { | |
152 | my $c = ++$counter; | |
44a8e56a | 153 | my $method = $AUTOLOAD; |
154 | *$AUTOLOAD = sub { "new B: In $method, $c" }; | |
155 | goto &$AUTOLOAD; | |
92d69e20 IZ |
156 | }; |
157 | ||
158 | test(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload | |
159 | test(A->eee(), "new B: In A::eee, 4"); # Which sticks | |
fb73857a | 160 | |
161 | # this test added due to bug discovery | |
6051dbdb | 162 | test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); |
f6ec51f7 GS |
163 | |
164 | # test that failed subroutine calls don't affect method calls | |
165 | { | |
166 | package A1; | |
167 | sub foo { "foo" } | |
168 | package A2; | |
169 | @ISA = 'A1'; | |
170 | package main; | |
171 | test(A2->foo(), "foo"); | |
172 | test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); | |
173 | test(A2->foo(), "foo"); | |
174 | } | |
c1899e02 GS |
175 | |
176 | { | |
177 | test(do { use Config; eval 'Config->foo()'; | |
178 | $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); | |
179 | test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; | |
180 | $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); | |
181 | } | |
182 | ||
183 | test(do { eval 'E->foo()'; | |
184 | $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); | |
185 | test(do { eval '$e = bless {}, "E"; $e->foo()'; | |
186 | $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); | |
187 | ||
f0670693 SC |
188 | # This is actually testing parsing of indirect objects and undefined subs |
189 | # print foo("bar") where foo does not exist is not an indirect object. | |
190 | # print foo "bar" where foo does not exist is an indirect object. | |
191 | eval { sub AUTOLOAD { "ok ", shift, "\n"; } }; | |
192 | print nonsuch(++$cnt); |