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è"); 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 120{ 121 package Pìckùp; 122 no warnings "deprecated"; 123 use UNIVERSAL qw( isa can VERSION ); 124 125 ::ok isa "Pìckùp", UNIVERSAL; 126 ::cmp_ok can( "Pìckùp", "can" ), '==', \&UNIVERSAL::can; 127 ::ok VERSION "UNIVERSAL" ; 128} 129 130package Fòò; 131 132sub DOES { 1 } 133 134package Bàr; 135 136@Bàr::ISA = 'Fòò'; 137 138package Bàz; 139 140package main; 141ok( Fòò->DOES( 'bàr' ), 'DOES() should call DOES() on class' ); 142ok( Bàr->DOES( 'Bàr' ), '... and should fall back to isa()' ); 143ok( Bàr->DOES( 'Fòò' ), '... even when inherited' ); 144ok( Bàz->DOES( 'Bàz' ), '... even without inheriting any other DOES()' ); 145ok( ! Bàz->DOES( 'Fòò' ), '... returning true or false appropriately' ); 146 147package Pìg; 148package Bòdìnè; 149Bòdìnè->isa('Pìg'); 150 151package main; 152eval { UNIVERSAL::DOES([], "fòò") }; 153like( $@, qr/Can't call method "DOES" on unblessed reference/, 154 'DOES call error message says DOES, not isa' ); 155 156# Tests for can seem to be split between here and method.t 157# Add the verbatim perl code mentioned in the comments of 158# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html 159# but never actually tested. 160is(UNIVERSAL->can("NòSùchPàckàgè::fòò"), undef); 161 162@splàtt::ISA = 'zlòpp'; 163ok (splàtt->isa('zlòpp')); 164ok (!splàtt->isa('plòp')); 165 166# This should reset the ->isa lookup cache 167@splàtt::ISA = 'plòp'; 168# And here is the new truth. 169ok (!splàtt->isa('zlòpp')); 170ok (splàtt->isa('plòp')); 171 172 173