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