t/001_mouse/057_subtype_without_where.t

   1 #!/usr/bin/perl -w
   2 use Test::More tests => 4;
   3 use Test::Exception;
   4
   5 use Mouse::Util::TypeConstraints;
   6
   7 {
   8     package Class;
   9     sub new {
  10         my $class = shift;
  11         return bless { @_ }, $class;
  12     }
  13 }
  14
  15 subtype 'Class',
  16     as 'Object',
  17     where { $_->isa('Class') };
  18
  19 subtype 'C', as 'Class'; # subtyping without "where"
  20
  21 coerce 'C',
  22     from 'Str',
  23     via { Class->new(content => $_) },
  24     from 'HashRef',
  25     via { Class->new(content => $_->{content}) };
  26
  27 {
  28     package A;
  29     use Mouse;
  30
  31     has foo => (
  32         is => 'ro',
  33         isa => 'C',
  34         coerce => 1,
  35         required => 1,
  36     );
  37 }
  38
  39 lives_and{
  40     my $a = A->new(foo => 'foobar');
  41     isa_ok $a->foo, 'Class';
  42     is $a->foo->{content}, 'foobar';
  43 };
  44
  45 lives_and{
  46     my $a = A->new(foo => { content => 42 });
  47     isa_ok $a->foo, 'Class';
  48     is $a->foo->{content}, 42;
  49 };