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 | ||
d70bfb04 | 13 | plan tests => 144; |
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 | |
072cb3f5 BF |
62 | ok ! $a->isa("Female\0NOT REALLY!"), "->isa is nul-clean."; |
63 | ||
3e44d7c6 | 64 | ok $a->isa("Human"); |
e09f3e01 | 65 | |
3e44d7c6 | 66 | ok ! $a->isa("Male"); |
e09f3e01 | 67 | |
3e44d7c6 | 68 | ok ! $a->isa('Programmer'); |
46e4b22b | 69 | |
3e44d7c6 | 70 | ok $a->isa("HASH"); |
986114cf | 71 | |
3e44d7c6 | 72 | ok $a->can("eat"); |
072cb3f5 | 73 | ok ! $a->can("eat\0Except not!"), "->can is nul-clean."; |
3e44d7c6 MS |
74 | ok ! $a->can("sleep"); |
75 | ok my $ref = $a->can("drink"); # returns a coderef | |
76 | is $a->$ref("tea"), "drinking tea"; # ... which works | |
77 | ok $ref = $a->can("sing"); | |
444e39b5 | 78 | eval { $a->$ref() }; |
3e44d7c6 | 79 | ok $@; # ... but not if no actual subroutine |
e09f3e01 | 80 | |
3e44d7c6 | 81 | ok (!Cedric->isa('Programmer')); |
46e4b22b | 82 | |
3e44d7c6 | 83 | ok (Cedric->isa('Human')); |
46e4b22b GS |
84 | |
85 | push(@Cedric::ISA,'Programmer'); | |
86 | ||
3e44d7c6 | 87 | ok (Cedric->isa('Programmer')); |
46e4b22b GS |
88 | |
89 | { | |
90 | package Alice; | |
91 | base::->import('Programmer'); | |
92 | } | |
93 | ||
3e44d7c6 MS |
94 | ok $a->isa('Programmer'); |
95 | ok $a->isa("Female"); | |
46e4b22b GS |
96 | |
97 | @Cedric::ISA = qw(Bob); | |
98 | ||
3e44d7c6 | 99 | ok (!Cedric->isa('Programmer')); |
46e4b22b | 100 | |
e09f3e01 MG |
101 | my $b = 'abc'; |
102 | my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); | |
103 | my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); | |
104 | for ($p=0; $p < @refs; $p++) { | |
105 | for ($q=0; $q < @vals; $q++) { | |
3e44d7c6 | 106 | is UNIVERSAL::isa($vals[$p], $refs[$q]), ($p==$q or $p+$q==1); |
e09f3e01 MG |
107 | }; |
108 | }; | |
109 | ||
68b40612 | 110 | ok UNIVERSAL::can(23, "can"); |
cee59a6a FC |
111 | ++${"23::foo"}; |
112 | ok UNIVERSAL::can("23", "can"), '"23" can can when the pack exists'; | |
113 | ok UNIVERSAL::can(23, "can"), '23 can can when the pack exists'; | |
4178f891 FC |
114 | sub IO::Handle::turn {} |
115 | ok UNIVERSAL::can(*STDOUT, 'turn'), 'globs with IOs can'; | |
116 | ok UNIVERSAL::can(\*STDOUT, 'turn'), 'globrefs with IOs can'; | |
2bde9ae6 | 117 | ok UNIVERSAL::can("STDOUT", 'turn'), 'IO barewords can'; |
e09f3e01 | 118 | |
3e44d7c6 | 119 | ok $a->can("VERSION"); |
e09f3e01 | 120 | |
3e44d7c6 MS |
121 | ok $a->can("can"); |
122 | ok ! $a->can("export_tags"); # a method in Exporter | |
e09f3e01 | 123 | |
3e44d7c6 | 124 | cmp_ok eval { $a->VERSION }, '==', 2.718; |
e09f3e01 | 125 | |
3e44d7c6 | 126 | ok ! (eval { $a->VERSION(2.719) }); |
ac0e6a2f | 127 | like $@, qr/^Alice version 2.719 required--this is only version 2.718 at /; |
44a8e56a | 128 | |
3e44d7c6 MS |
129 | ok (eval { $a->VERSION(2.718) }); |
130 | is $@, ''; | |
ff0cee69 | 131 | |
c2a3bbbf FC |
132 | ok ! (eval { $a->VERSION("version") }); |
133 | like $@, qr/^Invalid version format/; | |
134 | ||
135 | $aversion::VERSION = "version"; | |
136 | ok ! (eval { aversion->VERSION(2.719) }); | |
137 | like $@, qr/^Invalid version format/; | |
138 | ||
e09f3e01 | 139 | my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; |
ea8fae29 BS |
140 | ## The test for import here is *not* because we want to ensure that UNIVERSAL |
141 | ## can always import; it is an historical accident that UNIVERSAL can import. | |
9d116dd7 | 142 | if ('a' lt 'A') { |
4bf88892 | 143 | is $subs, "can import isa DOES VERSION"; |
9d116dd7 | 144 | } else { |
4bf88892 | 145 | is $subs, "DOES VERSION can import isa"; |
9d116dd7 | 146 | } |
ff0cee69 | 147 | |
3e44d7c6 | 148 | ok $a->isa("UNIVERSAL"); |
ff0cee69 | 149 | |
3e44d7c6 | 150 | ok ! UNIVERSAL::isa([], "UNIVERSAL"); |
b4c2bf25 | 151 | |
3e44d7c6 | 152 | ok ! UNIVERSAL::can({}, "can"); |
b4c2bf25 | 153 | |
3e44d7c6 | 154 | ok UNIVERSAL::isa(Alice => "UNIVERSAL"); |
b4c2bf25 | 155 | |
3e44d7c6 | 156 | cmp_ok UNIVERSAL::can(Alice => "can"), '==', \&UNIVERSAL::can; |
b4c2bf25 | 157 | |
84902520 | 158 | # now use UNIVERSAL.pm and see what changes |
e09f3e01 | 159 | eval "use UNIVERSAL"; |
ff0cee69 | 160 | |
3e44d7c6 | 161 | ok $a->isa("UNIVERSAL"); |
44a8e56a | 162 | |
46e4b22b | 163 | my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; |
84902520 | 164 | # XXX import being here is really a bug |
9d116dd7 | 165 | if ('a' lt 'A') { |
4bf88892 | 166 | is $sub2, "can import isa DOES VERSION"; |
9d116dd7 | 167 | } else { |
4bf88892 | 168 | is $sub2, "DOES VERSION can import isa"; |
9d116dd7 | 169 | } |
44a8e56a | 170 | |
e09f3e01 | 171 | eval 'sub UNIVERSAL::sleep {}'; |
3e44d7c6 | 172 | ok $a->can("sleep"); |
44a8e56a | 173 | |
68b40612 | 174 | ok UNIVERSAL::can($b, "can"); |
84902520 | 175 | |
3e44d7c6 | 176 | ok ! $a->can("export_tags"); # a method in Exporter |
83f7a2bc | 177 | |
3e44d7c6 | 178 | ok ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); |
ea8fae29 BS |
179 | |
180 | { | |
181 | package Pickup; | |
7fc874e8 | 182 | no warnings "deprecated"; |
ea8fae29 BS |
183 | use UNIVERSAL qw( isa can VERSION ); |
184 | ||
3e44d7c6 MS |
185 | ::ok isa "Pickup", UNIVERSAL; |
186 | ::cmp_ok can( "Pickup", "can" ), '==', \&UNIVERSAL::can; | |
187 | ::ok VERSION "UNIVERSAL" ; | |
ea8fae29 | 188 | } |
253ecd6d RGS |
189 | |
190 | { | |
191 | # test isa() and can() on magic variables | |
192 | "Human" =~ /(.*)/; | |
3e44d7c6 MS |
193 | ok $1->isa("Human"); |
194 | ok $1->can("eat"); | |
253ecd6d RGS |
195 | package HumanTie; |
196 | sub TIESCALAR { bless {} } | |
197 | sub FETCH { "Human" } | |
198 | tie my($x), "HumanTie"; | |
3e44d7c6 MS |
199 | ::ok $x->isa("Human"); |
200 | ::ok $x->can("eat"); | |
253ecd6d | 201 | } |
a1d407e8 DM |
202 | |
203 | # bugid 3284 | |
204 | # a second call to isa('UNIVERSAL') when @ISA is null failed due to caching | |
205 | ||
206 | @X::ISA=(); | |
207 | my $x = {}; bless $x, 'X'; | |
3e44d7c6 MS |
208 | ok $x->isa('UNIVERSAL'); |
209 | ok $x->isa('UNIVERSAL'); | |
2bfd5681 MS |
210 | |
211 | ||
212 | # Check that the "historical accident" of UNIVERSAL having an import() | |
213 | # method doesn't effect anyone else. | |
214 | eval { Some::Package->import("bar") }; | |
3e44d7c6 MS |
215 | is $@, ''; |
216 | ||
217 | ||
218 | # This segfaulted in a blead. | |
219 | fresh_perl_is('package Foo; Foo->VERSION; print "ok"', 'ok'); | |
220 | ||
1f656fcf FC |
221 | # So did this. |
222 | fresh_perl_is('$:; UNIVERSAL::isa(":","Unicode::String");print "ok"','ok'); | |
223 | ||
cbc021f9 | 224 | package Foo; |
225 | ||
4bf88892 | 226 | sub DOES { 1 } |
cbc021f9 | 227 | |
228 | package Bar; | |
229 | ||
230 | @Bar::ISA = 'Foo'; | |
231 | ||
232 | package Baz; | |
233 | ||
234 | package main; | |
4bf88892 RGS |
235 | ok( Foo->DOES( 'bar' ), 'DOES() should call DOES() on class' ); |
236 | ok( Bar->DOES( 'Bar' ), '... and should fall back to isa()' ); | |
237 | ok( Bar->DOES( 'Foo' ), '... even when inherited' ); | |
238 | ok( Baz->DOES( 'Baz' ), '... even without inheriting any other DOES()' ); | |
239 | ok( ! Baz->DOES( 'Foo' ), '... returning true or false appropriately' ); | |
ae6d515f | 240 | |
072cb3f5 BF |
241 | ok( ! "T"->DOES( "T\0" ), 'DOES() is nul-clean' ); |
242 | ok( ! Baz->DOES( "Baz\0Boy howdy" ), 'DOES() is nul-clean' ); | |
243 | ||
ae6d515f RGS |
244 | package Pig; |
245 | package Bodine; | |
246 | Bodine->isa('Pig'); | |
247 | *isa = \&UNIVERSAL::isa; | |
248 | eval { isa({}, 'HASH') }; | |
59e7186f RGS |
249 | ::is($@, '', "*isa correctly found"); |
250 | ||
251 | package main; | |
252 | eval { UNIVERSAL::DOES([], "foo") }; | |
253 | like( $@, qr/Can't call method "DOES" on unblessed reference/, | |
254 | 'DOES call error message says DOES, not isa' ); | |
b91ba1f2 NC |
255 | |
256 | # Tests for can seem to be split between here and method.t | |
257 | # Add the verbatim perl code mentioned in the comments of | |
258 | # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html | |
259 | # but never actually tested. | |
260 | is(UNIVERSAL->can("NoSuchPackage::foo"), undef); | |
5782d502 NC |
261 | |
262 | @splatt::ISA = 'zlopp'; | |
263 | ok (splatt->isa('zlopp')); | |
264 | ok (!splatt->isa('plop')); | |
265 | ||
266 | # This should reset the ->isa lookup cache | |
267 | @splatt::ISA = 'plop'; | |
268 | # And here is the new truth. | |
269 | ok (!splatt->isa('zlopp')); | |
270 | ok (splatt->isa('plop')); | |
271 | ||
cd477a63 RGS |
272 | use warnings "deprecated"; |
273 | { | |
274 | my $m; | |
275 | local $SIG{__WARN__} = sub { $m = $_[0] }; | |
252143cd | 276 | eval "use UNIVERSAL 'can'"; |
cd477a63 | 277 | like($m, qr/^UNIVERSAL->import is deprecated/, |
252143cd RS |
278 | "deprecation warning for UNIVERSAL->import('can')"); |
279 | ||
280 | undef $m; | |
281 | eval "use UNIVERSAL"; | |
282 | is($m, undef, | |
283 | "no deprecation warning for UNIVERSAL->import"); | |
cd477a63 | 284 | } |
27889255 B |
285 | |
286 | # Test: [perl #66112]: change @ISA inside sub isa | |
287 | { | |
288 | package RT66112::A; | |
289 | ||
290 | package RT66112::B; | |
291 | ||
292 | sub isa { | |
293 | my $self = shift; | |
294 | @ISA = qw/RT66112::A/; | |
295 | return $self->SUPER::isa(@_); | |
296 | } | |
297 | ||
298 | package RT66112::C; | |
299 | ||
300 | package RT66112::D; | |
301 | ||
302 | sub isa { | |
303 | my $self = shift; | |
304 | @RT66112::E::ISA = qw/RT66112::A/; | |
305 | return $self->SUPER::isa(@_); | |
306 | } | |
307 | ||
308 | package RT66112::E; | |
309 | ||
310 | package main; | |
311 | ||
312 | @RT66112::B::ISA = qw//; | |
313 | @RT66112::C::ISA = qw/RT66112::B/; | |
314 | @RT66112::T1::ISA = qw/RT66112::C/; | |
315 | ok(RT66112::T1->isa('RT66112::C'), "modify \@ISA in isa (RT66112::T1 isa RT66112::C)"); | |
316 | ||
317 | @RT66112::B::ISA = qw//; | |
318 | @RT66112::C::ISA = qw/RT66112::B/; | |
319 | @RT66112::T2::ISA = qw/RT66112::C/; | |
320 | ok(RT66112::T2->isa('RT66112::B'), "modify \@ISA in isa (RT66112::T2 isa RT66112::B)"); | |
321 | ||
322 | @RT66112::B::ISA = qw//; | |
323 | @RT66112::C::ISA = qw/RT66112::B/; | |
324 | @RT66112::T3::ISA = qw/RT66112::C/; | |
80ebaca2 | 325 | ok(RT66112::T3->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T3 isa RT66112::A)") or require mro, diag "@{mro::get_linear_isa('RT66112::T3')}"; |
27889255 B |
326 | |
327 | @RT66112::E::ISA = qw/RT66112::D/; | |
328 | @RT66112::T4::ISA = qw/RT66112::E/; | |
329 | ok(RT66112::T4->isa('RT66112::E'), "modify \@ISA in isa (RT66112::T4 isa RT66112::E)"); | |
330 | ||
331 | @RT66112::E::ISA = qw/RT66112::D/; | |
332 | @RT66112::T5::ISA = qw/RT66112::E/; | |
333 | ok(! RT66112::T5->isa('RT66112::D'), "modify \@ISA in isa (RT66112::T5 not isa RT66112::D)"); | |
334 | ||
335 | @RT66112::E::ISA = qw/RT66112::D/; | |
336 | @RT66112::T6::ISA = qw/RT66112::E/; | |
337 | ok(RT66112::T6->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T6 isa RT66112::A)"); | |
338 | } | |
68b40612 JL |
339 | |
340 | ok(Undeclared->can("can")); | |
341 | sub Undeclared::foo { } | |
342 | ok(Undeclared->can("foo")); | |
343 | ok(!Undeclared->can("something_else")); | |
61c2a935 JL |
344 | |
345 | ok(Undeclared->isa("UNIVERSAL")); | |
d70bfb04 JL |
346 | |
347 | # keep this at the end to avoid messing up earlier tests, since it modifies | |
348 | # @UNIVERSAL::ISA | |
349 | @UNIVERSAL::ISA = ('UniversalParent'); | |
350 | { package UniversalIsaTest1; } | |
351 | ok(UniversalIsaTest1->isa('UniversalParent')); | |
352 | ok(UniversalIsaTest2->isa('UniversalParent')); |