1#!/usr/bin/env perl -w 2 3# Test isa_ok() and can_ok() in test.pl 4 5use strict; 6use warnings; 7 8BEGIN { 9 chdir 't' if -d 't'; 10 push @INC, "."; 11 require 'test.pl'; 12} 13 14require Test::More; 15 16can_ok('Test::More', qw(require_ok use_ok ok is isnt like skip can_ok 17 pass fail eq_array eq_hash eq_set)); 18can_ok(bless({}, "Test::More"), qw(require_ok use_ok ok is isnt like skip 19 can_ok pass fail eq_array eq_hash eq_set)); 20 21 22isa_ok(bless([], "Foo"), "Foo"); 23isa_ok([], 'ARRAY'); 24isa_ok(\42, 'SCALAR'); 25{ 26 local %Bar::; 27 local @Foo::ISA = 'Bar'; 28 isa_ok( "Foo", "Bar" ); 29} 30 31 32# can_ok() & isa_ok should call can() & isa() on the given object, not 33# just class, in case of custom can() 34{ 35 local *Foo::can; 36 local *Foo::isa; 37 *Foo::can = sub { $_[0]->[0] }; 38 *Foo::isa = sub { $_[0]->[0] }; 39 my $foo = bless([0], 'Foo'); 40 ok( ! $foo->can('bar') ); 41 ok( ! $foo->isa('bar') ); 42 $foo->[0] = 1; 43 can_ok( $foo, 'blah'); 44 isa_ok( $foo, 'blah'); 45} 46 47 48note "object/class_ok"; { 49 { 50 package Child; 51 our @ISA = qw(Parent); 52 } 53 54 { 55 package Parent; 56 sub new { bless {}, shift } 57 } 58 59 # Unfortunately we can't usefully test the failure case without 60 # significantly modifying test.pl 61 class_ok "Child", "Parent"; 62 class_ok "Parent", "Parent"; 63 object_ok( Parent->new, "Parent" ); 64 object_ok( Child->new, "Parent" ); 65} 66 67done_testing; 68