1#!./perl
2#
3# check UNIVERSAL
4#
5
6BEGIN {
7    chdir 't' if -d 't';
8    $| = 1;
9    require "./test.pl";
10    set_up_inc(qw '../lib ../dist/base/lib');
11}
12
13use utf8;
14use open qw( :utf8 :std );
15
16plan tests => 90;
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è");
54ok $a->isa("main::Àlìcè");    # check that alternate class names work
55ok(("main::Àlìcè"->nèw)->isa("Àlìcè"));
56
57ok $a->isa("Bòb");
58ok $a->isa("main::Bòb");
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
120package Fòò;
121
122sub DOES { 1 }
123
124package Bàr;
125
126@Bàr::ISA = 'Fòò';
127
128package Bàz;
129
130package main;
131ok( Fòò->DOES( 'bàr' ), 'DOES() should call DOES() on class' );
132ok( Bàr->DOES( 'Bàr' ), '... and should fall back to isa()' );
133ok( Bàr->DOES( 'Fòò' ), '... even when inherited' );
134ok( Bàz->DOES( 'Bàz' ), '... even without inheriting any other DOES()' );
135ok( ! Bàz->DOES( 'Fòò' ), '... returning true or false appropriately' );
136
137package Pìg;
138package Bòdìnè;
139Bòdìnè->isa('Pìg');
140
141package main;
142eval { UNIVERSAL::DOES([], "fòò") };
143like( $@, qr/Can't call method "DOES" on unblessed reference/,
144    'DOES call error message says DOES, not isa' );
145
146# Tests for can seem to be split between here and method.t
147# Add the verbatim perl code mentioned in the comments of
148# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html
149# but never actually tested.
150is(UNIVERSAL->can("NòSùchPàckàgè::fòò"), undef);
151
152@splàtt::ISA = 'zlòpp';
153ok (splàtt->isa('zlòpp'));
154ok (!splàtt->isa('plòp'));
155
156# This should reset the ->isa lookup cache
157@splàtt::ISA = 'plòp';
158# And here is the new truth.
159ok (!splàtt->isa('zlòpp'));
160ok (splàtt->isa('plòp'));
161
162
163