Commit | Line | Data |
3d3b9c8a |
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, |
3845bd9a |
35 | required => 1, |
3d3b9c8a |
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 | }; |