1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7 require Config; 8} 9 10use strict; 11use feature 'isa'; 12 13plan 14; 14 15package BaseClass {} 16package DerivedClass { our @ISA = qw(BaseClass) } 17package CustomClass { 18 sub isa { length($_[1]) == 9; } 19} 20 21my $baseobj = bless {}, "BaseClass"; 22my $derivedobj = bless {}, "DerivedClass"; 23my $customobj = bless {}, "CustomClass"; 24 25# Bareword package name 26ok($baseobj isa BaseClass, '$baseobj isa BaseClass'); 27ok(not($baseobj isa Another::Class), '$baseobj is not Another::Class'); 28 29# String package name 30ok($baseobj isa "BaseClass", '$baseobj isa BaseClass'); 31ok(not($baseobj isa "DerivedClass"), '$baseobj is not DerivedClass'); 32 33ok($derivedobj isa "DerivedClass", '$derivedobj isa DerivedClass'); 34ok($derivedobj isa "BaseClass", '$derivedobj isa BaseClass'); 35 36# Expression giving a package name 37my $classname = "DerivedClass"; 38ok($derivedobj isa $classname, '$derivedobj isa DerivedClass via SV'); 39 40# Invoked on instance which overrides ->isa 41ok($customobj isa "Something", '$customobj isa Something'); 42ok(not($customobj isa "SomethingElse"), '$customobj isa SomethingElse'); 43 44ok(not(undef isa "BaseClass"), 'undef is not BaseClass'); 45ok(not([] isa "BaseClass"), 'ARRAYref is not BaseClass'); 46 47# Test that isa object method still works. 48 49ok($baseobj->isa('BaseClass'), '$baseobj isa BaseClass using object method'); 50ok(not($baseobj->isa('DerivedClass')), '$baseobj is not BaseClass using object method'); 51ok($derivedobj->isa('BaseClass'), '$derivedobj isa BaseClass using object method'); 52 53# TODO: Consider 54# LHS = other class 55