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