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