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