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