t/op/universal.t

   1 #!./perl
   2 #
   3 # check UNIVERSAL
   4 #
   5
   6 BEGIN {
   7     chdir 't' if -d 't';
   8     unshift @INC, '../lib' if -d '../lib';
   9 }
  10
  11 print "1..73\n";
  12
  13 $a = {};
  14 bless $a, "Bob";
  15 print "not " unless $a->isa("Bob");
  16 print "ok 1\n";
  17
  18 package Human;
  19 sub eat {}
  20
  21 package Female;
  22 @ISA=qw(Human);
  23
  24 package Alice;
  25 @ISA=qw(Bob Female);
  26 sub drink {}
  27 sub new { bless {} }
  28
  29 $Alice::VERSION = 2.718;
  30
  31 package main;
  32
  33 my $i = 2;
  34 sub test { print "not " unless shift; print "ok $i\n"; $i++; }
  35
  36 $a = new Alice;
  37
  38 test $a->isa("Alice");
  39
  40 test $a->isa("Bob");
  41
  42 test $a->isa("Female");
  43
  44 test $a->isa("Human");
  45
  46 test ! $a->isa("Male");
  47
  48 test $a->can("drink");
  49
  50 test $a->can("eat");
  51
  52 test ! $a->can("sleep");
  53
  54 my $b = 'abc';
  55 my @refs = qw(SCALAR SCALAR     LVALUE      GLOB ARRAY HASH CODE);
  56 my @vals = (  \$b,   \3.14, \substr($b,1,1), \*b,  [],  {}, sub {} );
  57 for ($p=0; $p < @refs; $p++) {
  58     for ($q=0; $q < @vals; $q++) {
  59         test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1);
  60     };
  61 };
  62
  63 test ! UNIVERSAL::can(23, "can");
  64
  65 test $a->can("VERSION");
  66
  67 test $a->can("can");
  68 test ! $a->can("export_tags");  # a method in Exporter
  69
  70 test (eval { $a->VERSION }) == 2.718;
  71
  72 test ! (eval { $a->VERSION(2.719) }) &&
  73          $@ =~ /^Alice version 2.71(?:9|8999\d+) required--this is only version 2.718 at /;
  74
  75 test (eval { $a->VERSION(2.718) }) && ! $@;
  76
  77 my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
  78 if ('a' lt 'A') {
  79     test $subs eq "can isa VERSION";
  80 } else {
  81     test $subs eq "VERSION can isa";
  82 }
  83
  84 test $a->isa("UNIVERSAL");
  85
  86 # now use UNIVERSAL.pm and see what changes
  87 eval "use UNIVERSAL";
  88
  89 test $a->isa("UNIVERSAL");
  90
  91 my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
  92 # XXX import being here is really a bug
  93 if ('a' lt 'A') {
  94     test $sub2 eq "can import isa VERSION";
  95 } else {
  96     test $sub2 eq "VERSION can import isa";
  97 }
  98
  99 eval 'sub UNIVERSAL::sleep {}';
 100 test $a->can("sleep");
 101
 102 test ! UNIVERSAL::can($b, "can");
 103
 104 test ! $a->can("export_tags");  # a method in Exporter
 105
 106 test ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH');