fix VMS test fail

[perl5.git] / t / uni / universal.t

#!./perl
#
# check UNIVERSAL
#

BEGIN {
    chdir 't' if -d 't';
    $| = 1;
    require "./test.pl";
    set_up_inc(qw '../lib ../dist/base/lib');
}

use utf8;
use open qw( :utf8 :std );

plan tests => 90;

$a = {};
bless $a, "Bòb";
ok $a->isa("Bòb");

package Hùmàn;
sub èàt {}

package Fèmàlè;
@ISA=qw(Hùmàn);

package Àlìcè;
@ISA=qw(Bòb Fèmàlè);
sub sìng;
sub drìnk { return "drinking " . $_[1]  }
sub nèw { bless {} }

$Àlìcè::VERSION = 2.718;

{
    package Cèdrìc;
    our @ISA;
    use base qw(Hùmàn);
}

{
    package Prògràmmèr;
    our $VERSION = 1.667;

    sub wrìtè_perl { 1 }
}

package main;

$a = nèw Àlìcè;

ok $a->isa("Àlìcè");
ok $a->isa("main::Àlìcè");    # check that alternate class names work
ok(("main::Àlìcè"->nèw)->isa("Àlìcè"));

ok $a->isa("Bòb");
ok $a->isa("main::Bòb");

ok $a->isa("Fèmàlè");

ok $a->isa("Hùmàn");

ok ! $a->isa("Màlè");

ok ! $a->isa('Prògràmmèr');

ok $a->isa("HASH");

ok $a->can("èàt");
ok ! $a->can("sleep");
ok my $ref = $a->can("drìnk");        # returns a coderef
is $a->$ref("tèà"), "drinking tèà"; # ... which works
ok $ref = $a->can("sìng");
eval { $a->$ref() };
ok $@;                                # ... but not if no actual subroutine

ok $a->can("VERSION");
cmp_ok eval { $a->VERSION }, '==', 2.718;
ok ! (eval { $a->VERSION(2.719) });
like $@, qr/^Àlìcè version 2.719 required--this is only version 2.718 at /u;

ok (!Cèdrìc->isa('Prògràmmèr'));

ok (Cèdrìc->isa('Hùmàn'));

push(@Cèdrìc::ISA,'Prògràmmèr');

ok (Cèdrìc->isa('Prògràmmèr'));

{
    package Àlìcè;
    base::->import('Prògràmmèr');
}

ok $a->isa('Prògràmmèr');
ok $a->isa("Fèmàlè");

@Cèdrìc::ISA = qw(Bòb);

ok (!Cèdrìc->isa('Prògràmmèr'));

my $b = 'abc';
my @refs = qw(SCALAR SCALAR     LVALUE      GLOB ARRAY HASH CODE);
my @vals = (  \$b,   \3.14, \substr($b,1,1), \*b,  [],  {}, sub {} );
for ($p=0; $p < @refs; $p++) {
    for ($q=0; $q < @vals; $q++) {
        is UNIVERSAL::isa($vals[$p], $refs[$q]), ($p==$q or $p+$q==1);
    };
};


ok UNIVERSAL::isa(Àlìcè => "UNIVERSAL");

cmp_ok UNIVERSAL::can(Àlìcè => "can"), '==', \&UNIVERSAL::can;

eval 'sub UNIVERSAL::slèèp {}';
ok $a->can("slèèp");

package Fòò;

sub DOES { 1 }

package Bàr;

@Bàr::ISA = 'Fòò';

package Bàz;

package main;
ok( Fòò->DOES( 'bàr' ), 'DOES() should call DOES() on class' );
ok( Bàr->DOES( 'Bàr' ), '... and should fall back to isa()' );
ok( Bàr->DOES( 'Fòò' ), '... even when inherited' );
ok( Bàz->DOES( 'Bàz' ), '... even without inheriting any other DOES()' );
ok( ! Bàz->DOES( 'Fòò' ), '... returning true or false appropriately' );

package Pìg;
package Bòdìnè;
Bòdìnè->isa('Pìg');

package main;
eval { UNIVERSAL::DOES([], "fòò") };
like( $@, qr/Can't call method "DOES" on unblessed reference/,
    'DOES call error message says DOES, not isa' );

# Tests for can seem to be split between here and method.t
# Add the verbatim perl code mentioned in the comments of
# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html
# but never actually tested.
is(UNIVERSAL->can("NòSùchPàckàgè::fòò"), undef);

@splàtt::ISA = 'zlòpp';
ok (splàtt->isa('zlòpp'));
ok (!splàtt->isa('plòp'));

# This should reset the ->isa lookup cache
@splàtt::ISA = 'plòp';
# And here is the new truth.
ok (!splàtt->isa('zlòpp'));
ok (splàtt->isa('plòp'));