t/040_type_constraints/034_duck_types.t

   1 #!/usr/bin/perl
   2 use strict;
   3 use warnings;
   4
   5 use Test::More tests => 4;
   6 use Test::Exception;
   7
   8 {
   9
  10     package Duck;
  11     use Moose;
  12
  13     sub quack { }
  14
  15 }
  16
  17 {
  18
  19     package Swan;
  20     use Moose;
  21
  22     sub honk { }
  23
  24 }
  25
  26 {
  27
  28     package RubberDuck;
  29     use Moose;
  30
  31     sub quack { }
  32
  33 }
  34
  35 {
  36
  37     package DucktypeTest;
  38     use Moose;
  39     use Moose::Util::TypeConstraints;
  40
  41     duck_type 'DuckType' => qw(quack);
  42
  43     has duck => (
  44         isa        => 'DuckType',
  45         is => 'ro',
  46         lazy_build => 1,
  47     );
  48
  49     sub _build_duck { Duck->new }
  50
  51     has swan => (
  52         isa => duck_type( [qw(honk)] ),
  53         is => 'ro',
  54     );
  55
  56 }
  57
  58 # try giving it a duck
  59 lives_ok { DucktypeTest->new( duck => Duck->new ) } 'the Duck lives okay';
  60
  61 # try giving it a swan which is like a duck, but not close enough
  62 throws_ok { DucktypeTest->new( duck => Swan->new ) }
  63 qr/Swan is missing methods 'quack'/,
  64     "the Swan doesn't quack";
  65
  66 # try giving it a rubber RubberDuckey
  67 lives_ok { DucktypeTest->new( swan => Swan->new ) } 'but a Swan can honk';
  68
  69 # try giving it a rubber RubberDuckey
  70 lives_ok { DucktypeTest->new( duck => RubberDuck->new ) }
  71 'the RubberDuck lives okay';
  72