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