t/001_mouse/062-duck_type.t

   1 #!perl
   2 use strict;
   3 use warnings;
   4
   5 use Test::More tests => 15;
   6
   7 use Mouse::Util::TypeConstraints qw(duck_type);
   8
   9 {
  10     package Foo;
  11     use Mouse;
  12
  13     sub a {}
  14
  15     package Bar;
  16     use Mouse;
  17
  18     extends qw(Foo);
  19
  20     sub b {}
  21
  22     package Baz;
  23     use Mouse;
  24
  25     sub can {
  26         my($class, $method) = @_;
  27         return $method eq 'b';
  28     }
  29 }
  30
  31 my $CanA   = duck_type CanA => qw(a);
  32 my $CanB  = duck_type CanB => [qw(b)];
  33 my $CanAB = duck_type [qw(a b)];
  34
  35 is $CanA->name, 'CanA';
  36 is $CanB->name, 'CanB';
  37 is $CanAB->name, '__ANON__';
  38
  39 ok $CanA->check(Foo->new);
  40 ok $CanA->check(Bar->new);
  41 ok!$CanA->check(Baz->new);
  42
  43 ok!$CanB->check(Foo->new);
  44 ok $CanB->check(Bar->new);
  45 ok $CanB->check(Baz->new);
  46
  47 ok!$CanAB->check(Foo->new);
  48 ok $CanAB->check(Bar->new);
  49 ok!$CanAB->check(Baz->new);
  50
  51 ok!$CanA->check(undef);
  52 ok!$CanA->check(1);
  53 ok!$CanA->check({});