Commit | Line | Data |
---|---|---|
44a8e56a | 1 | #!./perl |
2 | # | |
3 | # check UNIVERSAL | |
4 | # | |
5 | ||
e09f3e01 MG |
6 | BEGIN { |
7 | chdir 't' if -d 't'; | |
20822f61 | 8 | @INC = '../lib'; |
46e4b22b | 9 | $| = 1; |
3e44d7c6 | 10 | require "./test.pl"; |
e09f3e01 MG |
11 | } |
12 | ||
27889255 | 13 | plan tests => 123; |
44a8e56a | 14 | |
15 | $a = {}; | |
16 | bless $a, "Bob"; | |
3e44d7c6 | 17 | ok $a->isa("Bob"); |
44a8e56a | 18 | |
ff0cee69 | 19 | package Human; |
20 | sub eat {} | |
44a8e56a | 21 | |
ff0cee69 | 22 | package Female; |
23 | @ISA=qw(Human); | |
44a8e56a | 24 | |
ff0cee69 | 25 | package Alice; |
26 | @ISA=qw(Bob Female); | |
39d11b7f TB |
27 | sub sing; |
28 | sub drink { return "drinking " . $_[1] } | |
ff0cee69 | 29 | sub new { bless {} } |
44a8e56a | 30 | |
e09f3e01 MG |
31 | $Alice::VERSION = 2.718; |
32 | ||
46e4b22b GS |
33 | { |
34 | package Cedric; | |
35 | our @ISA; | |
36 | use base qw(Human); | |
37 | } | |
38 | ||
39 | { | |
40 | package Programmer; | |
41 | our $VERSION = 1.667; | |
42 | ||
43 | sub write_perl { 1 } | |
44 | } | |
45 | ||
44a8e56a | 46 | package main; |
e09f3e01 | 47 | |
3e44d7c6 | 48 | |
e09f3e01 | 49 | |
ff0cee69 | 50 | $a = new Alice; |
44a8e56a | 51 | |
3e44d7c6 MS |
52 | ok $a->isa("Alice"); |
53 | ok $a->isa("main::Alice"); # check that alternate class names work | |
44a8e56a | 54 | |
3e44d7c6 | 55 | ok(("main::Alice"->new)->isa("Alice")); |
178d71da | 56 | |
3e44d7c6 MS |
57 | ok $a->isa("Bob"); |
58 | ok $a->isa("main::Bob"); | |
e09f3e01 | 59 | |
3e44d7c6 | 60 | ok $a->isa("Female"); |
e09f3e01 | 61 | |
3e44d7c6 | 62 | ok $a->isa("Human"); |
e09f3e01 | 63 | |
3e44d7c6 | 64 | ok ! $a->isa("Male"); |
e09f3e01 | 65 | |
3e44d7c6 | 66 | ok ! $a->isa('Programmer'); |
46e4b22b | 67 | |
3e44d7c6 | 68 | ok $a->isa("HASH"); |
986114cf | 69 | |
3e44d7c6 MS |
70 | ok $a->can("eat"); |
71 | ok ! $a->can("sleep"); | |
72 | ok my $ref = $a->can("drink"); # returns a coderef | |
73 | is $a->$ref("tea"), "drinking tea"; # ... which works | |
74 | ok $ref = $a->can("sing"); | |
444e39b5 | 75 | eval { $a->$ref() }; |
3e44d7c6 | 76 | ok $@; # ... but not if no actual subroutine |
e09f3e01 | 77 | |
3e44d7c6 | 78 | ok (!Cedric->isa('Programmer')); |
46e4b22b | 79 | |
3e44d7c6 | 80 | ok (Cedric->isa('Human')); |
46e4b22b GS |
81 | |
82 | push(@Cedric::ISA,'Programmer'); | |
83 | ||
3e44d7c6 | 84 | ok (Cedric->isa('Programmer')); |
46e4b22b GS |
85 | |
86 | { | |
87 | package Alice; | |
88 | base::->import('Programmer'); | |
89 | } | |
90 | ||
3e44d7c6 MS |
91 | ok $a->isa('Programmer'); |
92 | ok $a->isa("Female"); | |
46e4b22b GS |
93 | |
94 | @Cedric::ISA = qw(Bob); | |
95 | ||
3e44d7c6 | 96 | ok (!Cedric->isa('Programmer')); |
46e4b22b | 97 | |
e09f3e01 MG |
98 | my $b = 'abc'; |
99 | my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); | |
100 | my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); | |
101 | for ($p=0; $p < @refs; $p++) { | |
102 | for ($q=0; $q < @vals; $q++) { | |
3e44d7c6 | 103 | is UNIVERSAL::isa($vals[$p], $refs[$q]), ($p==$q or $p+$q==1); |
e09f3e01 MG |
104 | }; |
105 | }; | |
106 | ||
3e44d7c6 | 107 | ok ! UNIVERSAL::can(23, "can"); |
e09f3e01 | 108 | |
3e44d7c6 | 109 | ok $a->can("VERSION"); |
e09f3e01 | 110 | |
3e44d7c6 MS |
111 | ok $a->can("can"); |
112 | ok ! $a->can("export_tags"); # a method in Exporter | |
e09f3e01 | 113 | |
3e44d7c6 | 114 | cmp_ok eval { $a->VERSION }, '==', 2.718; |
e09f3e01 | 115 | |
3e44d7c6 | 116 | ok ! (eval { $a->VERSION(2.719) }); |
ac0e6a2f | 117 | like $@, qr/^Alice version 2.719 required--this is only version 2.718 at /; |
44a8e56a | 118 | |
3e44d7c6 MS |
119 | ok (eval { $a->VERSION(2.718) }); |
120 | is $@, ''; | |
ff0cee69 | 121 | |
e09f3e01 | 122 | my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; |
ea8fae29 BS |
123 | ## The test for import here is *not* because we want to ensure that UNIVERSAL |
124 | ## can always import; it is an historical accident that UNIVERSAL can import. | |
9d116dd7 | 125 | if ('a' lt 'A') { |
4bf88892 | 126 | is $subs, "can import isa DOES VERSION"; |
9d116dd7 | 127 | } else { |
4bf88892 | 128 | is $subs, "DOES VERSION can import isa"; |
9d116dd7 | 129 | } |
ff0cee69 | 130 | |
3e44d7c6 | 131 | ok $a->isa("UNIVERSAL"); |
ff0cee69 | 132 | |
3e44d7c6 | 133 | ok ! UNIVERSAL::isa([], "UNIVERSAL"); |
b4c2bf25 | 134 | |
3e44d7c6 | 135 | ok ! UNIVERSAL::can({}, "can"); |
b4c2bf25 | 136 | |
3e44d7c6 | 137 | ok UNIVERSAL::isa(Alice => "UNIVERSAL"); |
b4c2bf25 | 138 | |
3e44d7c6 | 139 | cmp_ok UNIVERSAL::can(Alice => "can"), '==', \&UNIVERSAL::can; |
b4c2bf25 | 140 | |
84902520 | 141 | # now use UNIVERSAL.pm and see what changes |
e09f3e01 | 142 | eval "use UNIVERSAL"; |
ff0cee69 | 143 | |
3e44d7c6 | 144 | ok $a->isa("UNIVERSAL"); |
44a8e56a | 145 | |
46e4b22b | 146 | my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; |
84902520 | 147 | # XXX import being here is really a bug |
9d116dd7 | 148 | if ('a' lt 'A') { |
4bf88892 | 149 | is $sub2, "can import isa DOES VERSION"; |
9d116dd7 | 150 | } else { |
4bf88892 | 151 | is $sub2, "DOES VERSION can import isa"; |
9d116dd7 | 152 | } |
44a8e56a | 153 | |
e09f3e01 | 154 | eval 'sub UNIVERSAL::sleep {}'; |
3e44d7c6 | 155 | ok $a->can("sleep"); |
44a8e56a | 156 | |
3e44d7c6 | 157 | ok ! UNIVERSAL::can($b, "can"); |
84902520 | 158 | |
3e44d7c6 | 159 | ok ! $a->can("export_tags"); # a method in Exporter |
83f7a2bc | 160 | |
3e44d7c6 | 161 | ok ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); |
ea8fae29 BS |
162 | |
163 | { | |
164 | package Pickup; | |
165 | use UNIVERSAL qw( isa can VERSION ); | |
166 | ||
3e44d7c6 MS |
167 | ::ok isa "Pickup", UNIVERSAL; |
168 | ::cmp_ok can( "Pickup", "can" ), '==', \&UNIVERSAL::can; | |
169 | ::ok VERSION "UNIVERSAL" ; | |
ea8fae29 | 170 | } |
253ecd6d RGS |
171 | |
172 | { | |
173 | # test isa() and can() on magic variables | |
174 | "Human" =~ /(.*)/; | |
3e44d7c6 MS |
175 | ok $1->isa("Human"); |
176 | ok $1->can("eat"); | |
253ecd6d RGS |
177 | package HumanTie; |
178 | sub TIESCALAR { bless {} } | |
179 | sub FETCH { "Human" } | |
180 | tie my($x), "HumanTie"; | |
3e44d7c6 MS |
181 | ::ok $x->isa("Human"); |
182 | ::ok $x->can("eat"); | |
253ecd6d | 183 | } |
a1d407e8 DM |
184 | |
185 | # bugid 3284 | |
186 | # a second call to isa('UNIVERSAL') when @ISA is null failed due to caching | |
187 | ||
188 | @X::ISA=(); | |
189 | my $x = {}; bless $x, 'X'; | |
3e44d7c6 MS |
190 | ok $x->isa('UNIVERSAL'); |
191 | ok $x->isa('UNIVERSAL'); | |
2bfd5681 MS |
192 | |
193 | ||
194 | # Check that the "historical accident" of UNIVERSAL having an import() | |
195 | # method doesn't effect anyone else. | |
196 | eval { Some::Package->import("bar") }; | |
3e44d7c6 MS |
197 | is $@, ''; |
198 | ||
199 | ||
200 | # This segfaulted in a blead. | |
201 | fresh_perl_is('package Foo; Foo->VERSION; print "ok"', 'ok'); | |
202 | ||
cbc021f9 | 203 | package Foo; |
204 | ||
4bf88892 | 205 | sub DOES { 1 } |
cbc021f9 | 206 | |
207 | package Bar; | |
208 | ||
209 | @Bar::ISA = 'Foo'; | |
210 | ||
211 | package Baz; | |
212 | ||
213 | package main; | |
4bf88892 RGS |
214 | ok( Foo->DOES( 'bar' ), 'DOES() should call DOES() on class' ); |
215 | ok( Bar->DOES( 'Bar' ), '... and should fall back to isa()' ); | |
216 | ok( Bar->DOES( 'Foo' ), '... even when inherited' ); | |
217 | ok( Baz->DOES( 'Baz' ), '... even without inheriting any other DOES()' ); | |
218 | ok( ! Baz->DOES( 'Foo' ), '... returning true or false appropriately' ); | |
ae6d515f RGS |
219 | |
220 | package Pig; | |
221 | package Bodine; | |
222 | Bodine->isa('Pig'); | |
223 | *isa = \&UNIVERSAL::isa; | |
224 | eval { isa({}, 'HASH') }; | |
59e7186f RGS |
225 | ::is($@, '', "*isa correctly found"); |
226 | ||
227 | package main; | |
228 | eval { UNIVERSAL::DOES([], "foo") }; | |
229 | like( $@, qr/Can't call method "DOES" on unblessed reference/, | |
230 | 'DOES call error message says DOES, not isa' ); | |
b91ba1f2 NC |
231 | |
232 | # Tests for can seem to be split between here and method.t | |
233 | # Add the verbatim perl code mentioned in the comments of | |
234 | # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html | |
235 | # but never actually tested. | |
236 | is(UNIVERSAL->can("NoSuchPackage::foo"), undef); | |
5782d502 NC |
237 | |
238 | @splatt::ISA = 'zlopp'; | |
239 | ok (splatt->isa('zlopp')); | |
240 | ok (!splatt->isa('plop')); | |
241 | ||
242 | # This should reset the ->isa lookup cache | |
243 | @splatt::ISA = 'plop'; | |
244 | # And here is the new truth. | |
245 | ok (!splatt->isa('zlopp')); | |
246 | ok (splatt->isa('plop')); | |
247 | ||
cd477a63 RGS |
248 | use warnings "deprecated"; |
249 | { | |
250 | my $m; | |
251 | local $SIG{__WARN__} = sub { $m = $_[0] }; | |
252 | eval "use UNIVERSAL"; | |
253 | like($m, qr/^UNIVERSAL->import is deprecated/, | |
254 | "deprecation warning for UNIVERSAL->import"); | |
255 | } | |
27889255 B |
256 | |
257 | # Test: [perl #66112]: change @ISA inside sub isa | |
258 | { | |
259 | package RT66112::A; | |
260 | ||
261 | package RT66112::B; | |
262 | ||
263 | sub isa { | |
264 | my $self = shift; | |
265 | @ISA = qw/RT66112::A/; | |
266 | return $self->SUPER::isa(@_); | |
267 | } | |
268 | ||
269 | package RT66112::C; | |
270 | ||
271 | package RT66112::D; | |
272 | ||
273 | sub isa { | |
274 | my $self = shift; | |
275 | @RT66112::E::ISA = qw/RT66112::A/; | |
276 | return $self->SUPER::isa(@_); | |
277 | } | |
278 | ||
279 | package RT66112::E; | |
280 | ||
281 | package main; | |
282 | ||
283 | @RT66112::B::ISA = qw//; | |
284 | @RT66112::C::ISA = qw/RT66112::B/; | |
285 | @RT66112::T1::ISA = qw/RT66112::C/; | |
286 | ok(RT66112::T1->isa('RT66112::C'), "modify \@ISA in isa (RT66112::T1 isa RT66112::C)"); | |
287 | ||
288 | @RT66112::B::ISA = qw//; | |
289 | @RT66112::C::ISA = qw/RT66112::B/; | |
290 | @RT66112::T2::ISA = qw/RT66112::C/; | |
291 | ok(RT66112::T2->isa('RT66112::B'), "modify \@ISA in isa (RT66112::T2 isa RT66112::B)"); | |
292 | ||
293 | @RT66112::B::ISA = qw//; | |
294 | @RT66112::C::ISA = qw/RT66112::B/; | |
295 | @RT66112::T3::ISA = qw/RT66112::C/; | |
296 | ok(RT66112::T3->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T3 isa RT66112::A)"); | |
297 | ||
298 | @RT66112::E::ISA = qw/RT66112::D/; | |
299 | @RT66112::T4::ISA = qw/RT66112::E/; | |
300 | ok(RT66112::T4->isa('RT66112::E'), "modify \@ISA in isa (RT66112::T4 isa RT66112::E)"); | |
301 | ||
302 | @RT66112::E::ISA = qw/RT66112::D/; | |
303 | @RT66112::T5::ISA = qw/RT66112::E/; | |
304 | ok(! RT66112::T5->isa('RT66112::D'), "modify \@ISA in isa (RT66112::T5 not isa RT66112::D)"); | |
305 | ||
306 | @RT66112::E::ISA = qw/RT66112::D/; | |
307 | @RT66112::T6::ISA = qw/RT66112::E/; | |
308 | ok(RT66112::T6->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T6 isa RT66112::A)"); | |
309 | } |