1#!./perl 2# 3# check UNIVERSAL 4# 5 6BEGIN { 7 chdir 't' if -d 't'; 8 @INC = '../lib'; 9 $| = 1; 10} 11 12print "1..100\n"; 13 14$a = {}; 15bless $a, "Bob"; 16print "not " unless $a->isa("Bob"); 17print "ok 1\n"; 18 19package Human; 20sub eat {} 21 22package Female; 23@ISA=qw(Human); 24 25package Alice; 26@ISA=qw(Bob Female); 27sub sing; 28sub drink { return "drinking " . $_[1] } 29sub new { bless {} } 30 31$Alice::VERSION = 2.718; 32 33{ 34 package Cedric; 35 our @ISA; 36 use base qw(Human); 37} 38 39{ 40 package Programmer; 41 our $VERSION = 1.667; 42 43 sub write_perl { 1 } 44} 45 46package main; 47 48{ my $i = 2; 49 sub test { 50 print "not " unless $_[0]; 51 print "ok ", $i++; 52 print " # at ", (caller)[1], ", line ", (caller)[2] unless $_[0]; 53 print "\n"; 54 } 55} 56 57$a = new Alice; 58 59test $a->isa("Alice"); 60test $a->isa("main::Alice"); # check that alternate class names work 61 62test(("main::Alice"->new)->isa("Alice")); 63 64test $a->isa("Bob"); 65test $a->isa("main::Bob"); 66 67test $a->isa("Female"); 68 69test $a->isa("Human"); 70 71test ! $a->isa("Male"); 72 73test ! $a->isa('Programmer'); 74 75test $a->isa("HASH"); 76 77test $a->can("eat"); 78test ! $a->can("sleep"); 79test my $ref = $a->can("drink"); # returns a coderef 80test $a->$ref("tea") eq "drinking tea"; # ... which works 81test $ref = $a->can("sing"); 82eval { $a->$ref() }; 83test $@; # ... but not if no actual subroutine 84 85test (!Cedric->isa('Programmer')); 86 87test (Cedric->isa('Human')); 88 89push(@Cedric::ISA,'Programmer'); 90 91test (Cedric->isa('Programmer')); 92 93{ 94 package Alice; 95 base::->import('Programmer'); 96} 97 98test $a->isa('Programmer'); 99test $a->isa("Female"); 100 101@Cedric::ISA = qw(Bob); 102 103test (!Cedric->isa('Programmer')); 104 105my $b = 'abc'; 106my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); 107my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); 108for ($p=0; $p < @refs; $p++) { 109 for ($q=0; $q < @vals; $q++) { 110 test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1); 111 }; 112}; 113 114test ! UNIVERSAL::can(23, "can"); 115 116test $a->can("VERSION"); 117 118test $a->can("can"); 119test ! $a->can("export_tags"); # a method in Exporter 120 121test (eval { $a->VERSION }) == 2.718; 122 123test ! (eval { $a->VERSION(2.719) }) && 124 $@ =~ /^Alice version 2.71(?:9|8999\d+) required--this is only version 2.718 at /; 125 126test (eval { $a->VERSION(2.718) }) && ! $@; 127 128my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; 129## The test for import here is *not* because we want to ensure that UNIVERSAL 130## can always import; it is an historical accident that UNIVERSAL can import. 131if ('a' lt 'A') { 132 test $subs eq "can import isa VERSION"; 133} else { 134 test $subs eq "VERSION can import isa"; 135} 136 137test $a->isa("UNIVERSAL"); 138 139test ! UNIVERSAL::isa([], "UNIVERSAL"); 140 141test ! UNIVERSAL::can({}, "can"); 142 143test UNIVERSAL::isa(Alice => "UNIVERSAL"); 144 145test UNIVERSAL::can(Alice => "can") == \&UNIVERSAL::can; 146 147# now use UNIVERSAL.pm and see what changes 148eval "use UNIVERSAL"; 149 150test $a->isa("UNIVERSAL"); 151 152my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; 153# XXX import being here is really a bug 154if ('a' lt 'A') { 155 test $sub2 eq "can import isa VERSION"; 156} else { 157 test $sub2 eq "VERSION can import isa"; 158} 159 160eval 'sub UNIVERSAL::sleep {}'; 161test $a->can("sleep"); 162 163test ! UNIVERSAL::can($b, "can"); 164 165test ! $a->can("export_tags"); # a method in Exporter 166 167test ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); 168 169{ 170 package Pickup; 171 use UNIVERSAL qw( isa can VERSION ); 172 173 main::test isa "Pickup", UNIVERSAL; 174 main::test can( "Pickup", "can" ) == \&UNIVERSAL::can; 175 main::test VERSION "UNIVERSAL" ; 176} 177 178{ 179 # test isa() and can() on magic variables 180 "Human" =~ /(.*)/; 181 test $1->isa("Human"); 182 test $1->can("eat"); 183 package HumanTie; 184 sub TIESCALAR { bless {} } 185 sub FETCH { "Human" } 186 tie my($x), "HumanTie"; 187 ::test $x->isa("Human"); 188 ::test $x->can("eat"); 189} 190 191# bugid 3284 192# a second call to isa('UNIVERSAL') when @ISA is null failed due to caching 193 194@X::ISA=(); 195my $x = {}; bless $x, 'X'; 196test $x->isa('UNIVERSAL'); 197test $x->isa('UNIVERSAL'); 198