This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
uni/universal.t tests passing
[perl5.git] / t / uni / universal.t
CommitLineData
072cb3f5
BF
1#!./perl
2#
3# check UNIVERSAL
4#
5
6BEGIN {
7 chdir 't' if -d 't';
8 @INC = '../lib';
9 $| = 1;
10 require "./test.pl";
11}
12
13use utf8;
14use open qw( :utf8 :std );
15
16plan tests => 93;
17
18$a = {};
19bless $a, "Bòb";
20ok $a->isa("Bòb");
21
22package Hùmàn;
23sub èàt {}
24
25package Fèmàlè;
26@ISA=qw(Hùmàn);
27
28package Àlìcè;
29@ISA=qw(Bòb Fèmàlè);
30sub sìng;
31sub drìnk { return "drinking " . $_[1] }
32sub nèw { bless {} }
33
34$Àlìcè::VERSION = 2.718;
35
36{
37 package Cèdrìc;
38 our @ISA;
39 use base qw(Hùmàn);
40}
41
42{
43 package Prògràmmèr;
44 our $VERSION = 1.667;
45
46 sub wrìtè_perl { 1 }
47}
48
49package main;
50
51$a = nèw Àlìcè;
52
53ok $a->isa("Àlìcè");
1b48ba24 54ok $a->isa("main::Àlìcè"); # check that alternate class names work
072cb3f5
BF
55ok(("main::Àlìcè"->nèw)->isa("Àlìcè"));
56
57ok $a->isa("Bòb");
1b48ba24 58ok $a->isa("main::Bòb");
072cb3f5
BF
59
60ok $a->isa("Fèmàlè");
61
62ok $a->isa("Hùmàn");
63
64ok ! $a->isa("Màlè");
65
66ok ! $a->isa('Prògràmmèr');
67
68ok $a->isa("HASH");
69
70ok $a->can("èàt");
71ok ! $a->can("sleep");
72ok my $ref = $a->can("drìnk"); # returns a coderef
73is $a->$ref("tèà"), "drinking tèà"; # ... which works
74ok $ref = $a->can("sìng");
75eval { $a->$ref() };
76ok $@; # ... but not if no actual subroutine
77
78ok $a->can("VERSION");
79cmp_ok eval { $a->VERSION }, '==', 2.718;
80ok ! (eval { $a->VERSION(2.719) });
81like $@, qr/^Àlìcè version 2.719 required--this is only version 2.718 at /u;
82
83ok (!Cèdrìc->isa('Prògràmmèr'));
84
85ok (Cèdrìc->isa('Hùmàn'));
86
87push(@Cèdrìc::ISA,'Prògràmmèr');
88
89ok (Cèdrìc->isa('Prògràmmèr'));
90
91{
92 package Àlìcè;
93 base::->import('Prògràmmèr');
94}
95
96ok $a->isa('Prògràmmèr');
97ok $a->isa("Fèmàlè");
98
99@Cèdrìc::ISA = qw(Bòb);
100
101ok (!Cèdrìc->isa('Prògràmmèr'));
102
103my $b = 'abc';
104my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE);
105my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} );
106for ($p=0; $p < @refs; $p++) {
107 for ($q=0; $q < @vals; $q++) {
108 is UNIVERSAL::isa($vals[$p], $refs[$q]), ($p==$q or $p+$q==1);
109 };
110};
111
112
113ok UNIVERSAL::isa(Àlìcè => "UNIVERSAL");
114
115cmp_ok UNIVERSAL::can(Àlìcè => "can"), '==', \&UNIVERSAL::can;
116
117eval 'sub UNIVERSAL::slèèp {}';
118ok $a->can("slèèp");
119
120{
121 package Pìckùp;
122 use UNIVERSAL qw( isa can VERSION );
123
124 ::ok isa "Pìckùp", UNIVERSAL;
125 ::cmp_ok can( "Pìckùp", "can" ), '==', \&UNIVERSAL::can;
126 ::ok VERSION "UNIVERSAL" ;
127}
128
129package Fòò;
130
131sub DOES { 1 }
132
133package Bàr;
134
135@Bàr::ISA = 'Fòò';
136
137package Bàz;
138
139package main;
140ok( Fòò->DOES( 'bàr' ), 'DOES() should call DOES() on class' );
141ok( Bàr->DOES( 'Bàr' ), '... and should fall back to isa()' );
142ok( Bàr->DOES( 'Fòò' ), '... even when inherited' );
143ok( Bàz->DOES( 'Bàz' ), '... even without inheriting any other DOES()' );
144ok( ! Bàz->DOES( 'Fòò' ), '... returning true or false appropriately' );
145
146package Pìg;
147package Bòdìnè;
148Bòdìnè->isa('Pìg');
149
150package main;
151eval { UNIVERSAL::DOES([], "fòò") };
152like( $@, qr/Can't call method "DOES" on unblessed reference/,
153 'DOES call error message says DOES, not isa' );
154
155# Tests for can seem to be split between here and method.t
156# Add the verbatim perl code mentioned in the comments of
157# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html
158# but never actually tested.
159is(UNIVERSAL->can("NòSùchPàckàgè::fòò"), undef);
160
161@splàtt::ISA = 'zlòpp';
162ok (splàtt->isa('zlòpp'));
163ok (!splàtt->isa('plòp'));
164
165# This should reset the ->isa lookup cache
166@splàtt::ISA = 'plòp';
167# And here is the new truth.
168ok (!splàtt->isa('zlòpp'));
169ok (splàtt->isa('plòp'));
170
171