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