1#!./perl 2# 3# check UNIVERSAL 4# 5 6BEGIN { 7 chdir 't' if -d 't'; 8 @INC = '../lib'; 9 $| = 1; 10 require "./test.pl"; 11} 12 13plan tests => 124; 14 15$a = {}; 16bless $a, "Bob"; 17ok $a->isa("Bob"); 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 49 50$a = new Alice; 51 52ok $a->isa("Alice"); 53ok $a->isa("main::Alice"); # check that alternate class names work 54 55ok(("main::Alice"->new)->isa("Alice")); 56 57ok $a->isa("Bob"); 58ok $a->isa("main::Bob"); 59 60ok $a->isa("Female"); 61 62ok $a->isa("Human"); 63 64ok ! $a->isa("Male"); 65 66ok ! $a->isa('Programmer'); 67 68ok $a->isa("HASH"); 69 70ok $a->can("eat"); 71ok ! $a->can("sleep"); 72ok my $ref = $a->can("drink"); # returns a coderef 73is $a->$ref("tea"), "drinking tea"; # ... which works 74ok $ref = $a->can("sing"); 75eval { $a->$ref() }; 76ok $@; # ... but not if no actual subroutine 77 78ok (!Cedric->isa('Programmer')); 79 80ok (Cedric->isa('Human')); 81 82push(@Cedric::ISA,'Programmer'); 83 84ok (Cedric->isa('Programmer')); 85 86{ 87 package Alice; 88 base::->import('Programmer'); 89} 90 91ok $a->isa('Programmer'); 92ok $a->isa("Female"); 93 94@Cedric::ISA = qw(Bob); 95 96ok (!Cedric->isa('Programmer')); 97 98my $b = 'abc'; 99my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); 100my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); 101for ($p=0; $p < @refs; $p++) { 102 for ($q=0; $q < @vals; $q++) { 103 is UNIVERSAL::isa($vals[$p], $refs[$q]), ($p==$q or $p+$q==1); 104 }; 105}; 106 107ok ! UNIVERSAL::can(23, "can"); 108 109ok $a->can("VERSION"); 110 111ok $a->can("can"); 112ok ! $a->can("export_tags"); # a method in Exporter 113 114cmp_ok eval { $a->VERSION }, '==', 2.718; 115 116ok ! (eval { $a->VERSION(2.719) }); 117like $@, qr/^Alice version 2.719 required--this is only version 2.718 at /; 118 119ok (eval { $a->VERSION(2.718) }); 120is $@, ''; 121 122my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; 123## The test for import here is *not* because we want to ensure that UNIVERSAL 124## can always import; it is an historical accident that UNIVERSAL can import. 125if ('a' lt 'A') { 126 is $subs, "can import isa DOES VERSION"; 127} else { 128 is $subs, "DOES VERSION can import isa"; 129} 130 131ok $a->isa("UNIVERSAL"); 132 133ok ! UNIVERSAL::isa([], "UNIVERSAL"); 134 135ok ! UNIVERSAL::can({}, "can"); 136 137ok UNIVERSAL::isa(Alice => "UNIVERSAL"); 138 139cmp_ok UNIVERSAL::can(Alice => "can"), '==', \&UNIVERSAL::can; 140 141# now use UNIVERSAL.pm and see what changes 142eval "use UNIVERSAL"; 143 144ok $a->isa("UNIVERSAL"); 145 146my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; 147# XXX import being here is really a bug 148if ('a' lt 'A') { 149 is $sub2, "can import isa DOES VERSION"; 150} else { 151 is $sub2, "DOES VERSION can import isa"; 152} 153 154eval 'sub UNIVERSAL::sleep {}'; 155ok $a->can("sleep"); 156 157ok ! UNIVERSAL::can($b, "can"); 158 159ok ! $a->can("export_tags"); # a method in Exporter 160 161ok ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); 162 163{ 164 package Pickup; 165 use UNIVERSAL qw( isa can VERSION ); 166 167 ::ok isa "Pickup", UNIVERSAL; 168 ::cmp_ok can( "Pickup", "can" ), '==', \&UNIVERSAL::can; 169 ::ok VERSION "UNIVERSAL" ; 170} 171 172{ 173 # test isa() and can() on magic variables 174 "Human" =~ /(.*)/; 175 ok $1->isa("Human"); 176 ok $1->can("eat"); 177 package HumanTie; 178 sub TIESCALAR { bless {} } 179 sub FETCH { "Human" } 180 tie my($x), "HumanTie"; 181 ::ok $x->isa("Human"); 182 ::ok $x->can("eat"); 183} 184 185# bugid 3284 186# a second call to isa('UNIVERSAL') when @ISA is null failed due to caching 187 188@X::ISA=(); 189my $x = {}; bless $x, 'X'; 190ok $x->isa('UNIVERSAL'); 191ok $x->isa('UNIVERSAL'); 192 193 194# Check that the "historical accident" of UNIVERSAL having an import() 195# method doesn't effect anyone else. 196eval { Some::Package->import("bar") }; 197is $@, ''; 198 199 200# This segfaulted in a blead. 201fresh_perl_is('package Foo; Foo->VERSION; print "ok"', 'ok'); 202 203package Foo; 204 205sub DOES { 1 } 206 207package Bar; 208 209@Bar::ISA = 'Foo'; 210 211package Baz; 212 213package main; 214ok( Foo->DOES( 'bar' ), 'DOES() should call DOES() on class' ); 215ok( Bar->DOES( 'Bar' ), '... and should fall back to isa()' ); 216ok( Bar->DOES( 'Foo' ), '... even when inherited' ); 217ok( Baz->DOES( 'Baz' ), '... even without inheriting any other DOES()' ); 218ok( ! Baz->DOES( 'Foo' ), '... returning true or false appropriately' ); 219 220package Pig; 221package Bodine; 222Bodine->isa('Pig'); 223*isa = \&UNIVERSAL::isa; 224eval { isa({}, 'HASH') }; 225::is($@, '', "*isa correctly found"); 226 227package main; 228eval { UNIVERSAL::DOES([], "foo") }; 229like( $@, qr/Can't call method "DOES" on unblessed reference/, 230 'DOES call error message says DOES, not isa' ); 231 232# Tests for can seem to be split between here and method.t 233# Add the verbatim perl code mentioned in the comments of 234# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html 235# but never actually tested. 236is(UNIVERSAL->can("NoSuchPackage::foo"), undef); 237 238@splatt::ISA = 'zlopp'; 239ok (splatt->isa('zlopp')); 240ok (!splatt->isa('plop')); 241 242# This should reset the ->isa lookup cache 243@splatt::ISA = 'plop'; 244# And here is the new truth. 245ok (!splatt->isa('zlopp')); 246ok (splatt->isa('plop')); 247 248use warnings "deprecated"; 249{ 250 my $m; 251 local $SIG{__WARN__} = sub { $m = $_[0] }; 252 eval "use UNIVERSAL 'can'"; 253 like($m, qr/^UNIVERSAL->import is deprecated/, 254 "deprecation warning for UNIVERSAL->import('can')"); 255 256 undef $m; 257 eval "use UNIVERSAL"; 258 is($m, undef, 259 "no deprecation warning for UNIVERSAL->import"); 260} 261 262# Test: [perl #66112]: change @ISA inside sub isa 263{ 264 package RT66112::A; 265 266 package RT66112::B; 267 268 sub isa { 269 my $self = shift; 270 @ISA = qw/RT66112::A/; 271 return $self->SUPER::isa(@_); 272 } 273 274 package RT66112::C; 275 276 package RT66112::D; 277 278 sub isa { 279 my $self = shift; 280 @RT66112::E::ISA = qw/RT66112::A/; 281 return $self->SUPER::isa(@_); 282 } 283 284 package RT66112::E; 285 286 package main; 287 288 @RT66112::B::ISA = qw//; 289 @RT66112::C::ISA = qw/RT66112::B/; 290 @RT66112::T1::ISA = qw/RT66112::C/; 291 ok(RT66112::T1->isa('RT66112::C'), "modify \@ISA in isa (RT66112::T1 isa RT66112::C)"); 292 293 @RT66112::B::ISA = qw//; 294 @RT66112::C::ISA = qw/RT66112::B/; 295 @RT66112::T2::ISA = qw/RT66112::C/; 296 ok(RT66112::T2->isa('RT66112::B'), "modify \@ISA in isa (RT66112::T2 isa RT66112::B)"); 297 298 @RT66112::B::ISA = qw//; 299 @RT66112::C::ISA = qw/RT66112::B/; 300 @RT66112::T3::ISA = qw/RT66112::C/; 301 ok(RT66112::T3->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T3 isa RT66112::A)"); 302 303 @RT66112::E::ISA = qw/RT66112::D/; 304 @RT66112::T4::ISA = qw/RT66112::E/; 305 ok(RT66112::T4->isa('RT66112::E'), "modify \@ISA in isa (RT66112::T4 isa RT66112::E)"); 306 307 @RT66112::E::ISA = qw/RT66112::D/; 308 @RT66112::T5::ISA = qw/RT66112::E/; 309 ok(! RT66112::T5->isa('RT66112::D'), "modify \@ISA in isa (RT66112::T5 not isa RT66112::D)"); 310 311 @RT66112::E::ISA = qw/RT66112::D/; 312 @RT66112::T6::ISA = qw/RT66112::E/; 313 ok(RT66112::T6->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T6 isa RT66112::A)"); 314} 315