t/uni/universal.t

   1 #!./perl
   2 #
   3 # check UNIVERSAL
   4 #
   5
   6 BEGIN {
   7     chdir 't' if -d 't';
   8     $| = 1;
   9     require "./test.pl";
  10     set_up_inc(qw '../lib ../dist/base/lib');
  11 }
  12
  13 use utf8;
  14 use open qw( :utf8 :std );
  15
  16 plan tests => 90;
  17
  18 $a = {};
  19 bless $a, "Bòb";
  20 ok $a->isa("Bòb");
  21
  22 package Hùmàn;
  23 sub èàt {}
  24
  25 package Fèmàlè;
  26 @ISA=qw(Hùmàn);
  27
  28 package Àlìcè;
  29 @ISA=qw(Bòb Fèmàlè);
  30 sub sìng;
  31 sub drìnk { return "drinking " . $_[1]  }
  32 sub 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
  49 package main;
  50
  51 $a = nèw Àlìcè;
  52
  53 ok $a->isa("Àlìcè");
  54 ok $a->isa("main::Àlìcè");    # check that alternate class names work
  55 ok(("main::Àlìcè"->nèw)->isa("Àlìcè"));
  56
  57 ok $a->isa("Bòb");
  58 ok $a->isa("main::Bòb");
  59
  60 ok $a->isa("Fèmàlè");
  61
  62 ok $a->isa("Hùmàn");
  63
  64 ok ! $a->isa("Màlè");
  65
  66 ok ! $a->isa('Prògràmmèr');
  67
  68 ok $a->isa("HASH");
  69
  70 ok $a->can("èàt");
  71 ok ! $a->can("sleep");
  72 ok my $ref = $a->can("drìnk");        # returns a coderef
  73 is $a->$ref("tèà"), "drinking tèà"; # ... which works
  74 ok $ref = $a->can("sìng");
  75 eval { $a->$ref() };
  76 ok $@;                                # ... but not if no actual subroutine
  77
  78 ok $a->can("VERSION");
  79 cmp_ok eval { $a->VERSION }, '==', 2.718;
  80 ok ! (eval { $a->VERSION(2.719) });
  81 like $@, qr/^Àlìcè version 2.719 required--this is only version 2.718 at /u;
  82
  83 ok (!Cèdrìc->isa('Prògràmmèr'));
  84
  85 ok (Cèdrìc->isa('Hùmàn'));
  86
  87 push(@Cèdrìc::ISA,'Prògràmmèr');
  88
  89 ok (Cèdrìc->isa('Prògràmmèr'));
  90
  91 {
  92     package Àlìcè;
  93     base::->import('Prògràmmèr');
  94 }
  95
  96 ok $a->isa('Prògràmmèr');
  97 ok $a->isa("Fèmàlè");
  98
  99 @Cèdrìc::ISA = qw(Bòb);
 100
 101 ok (!Cèdrìc->isa('Prògràmmèr'));
 102
 103 my $b = 'abc';
 104 my @refs = qw(SCALAR SCALAR     LVALUE      GLOB ARRAY HASH CODE);
 105 my @vals = (  \$b,   \3.14, \substr($b,1,1), \*b,  [],  {}, sub {} );
 106 for ($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
 113 ok UNIVERSAL::isa(Àlìcè => "UNIVERSAL");
 114
 115 cmp_ok UNIVERSAL::can(Àlìcè => "can"), '==', \&UNIVERSAL::can;
 116
 117 eval 'sub UNIVERSAL::slèèp {}';
 118 ok $a->can("slèèp");
 119
 120 package Fòò;
 121
 122 sub DOES { 1 }
 123
 124 package Bàr;
 125
 126 @Bàr::ISA = 'Fòò';
 127
 128 package Bàz;
 129
 130 package main;
 131 ok( Fòò->DOES( 'bàr' ), 'DOES() should call DOES() on class' );
 132 ok( Bàr->DOES( 'Bàr' ), '... and should fall back to isa()' );
 133 ok( Bàr->DOES( 'Fòò' ), '... even when inherited' );
 134 ok( Bàz->DOES( 'Bàz' ), '... even without inheriting any other DOES()' );
 135 ok( ! Bàz->DOES( 'Fòò' ), '... returning true or false appropriately' );
 136
 137 package Pìg;
 138 package Bòdìnè;
 139 Bòdìnè->isa('Pìg');
 140
 141 package main;
 142 eval { UNIVERSAL::DOES([], "fòò") };
 143 like( $@, 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.
 150 is(UNIVERSAL->can("NòSùchPàckàgè::fòò"), undef);
 151
 152 @splàtt::ISA = 'zlòpp';
 153 ok (splàtt->isa('zlòpp'));
 154 ok (!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.
 159 ok (!splàtt->isa('zlòpp'));
 160 ok (splàtt->isa('plòp'));
 161
 162