t/test_pl/can_isa_ok.t

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