Commit | Line | Data |
b2b106d7 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Test::More tests => 26; |
7 | use Test::Exception; |
8 | |
9 | use Mouse::Util::TypeConstraints; |
10 | use Mouse::Meta::TypeConstraint; |
11 | |
12 | |
13 | ## Create a subclass with a custom method |
14 | |
15 | { |
16 | package Test::Mouse::Meta::TypeConstraint::AnySubType; |
17 | use Mouse; |
18 | extends 'Mouse::Meta::TypeConstraint'; |
19 | |
20 | sub my_custom_method { |
21 | return 1; |
22 | } |
23 | } |
24 | |
25 | my $Int = find_type_constraint('Int'); |
26 | ok $Int, 'Got a good type contstraint'; |
27 | |
28 | my $parent = Test::Mouse::Meta::TypeConstraint::AnySubType->new({ |
29 | name => "Test::Mouse::Meta::TypeConstraint::AnySubType" , |
30 | parent => $Int, |
31 | }); |
32 | |
33 | ok $parent, 'Created type constraint'; |
34 | ok $parent->check(1), 'Correctly passed'; |
35 | ok ! $parent->check('a'), 'correctly failed'; |
36 | ok $parent->my_custom_method, 'found the custom method'; |
37 | |
38 | my $subtype1 = subtype 'another_subtype' => as $parent; |
39 | |
40 | ok $subtype1, 'Created type constraint'; |
41 | ok $subtype1->check(1), 'Correctly passed'; |
42 | ok ! $subtype1->check('a'), 'correctly failed'; |
43 | ok $subtype1->my_custom_method, 'found the custom method'; |
44 | |
45 | |
46 | my $subtype2 = subtype 'another_subtype' => as $subtype1 => where { $_ < 10 }; |
47 | |
48 | ok $subtype2, 'Created type constraint'; |
49 | ok $subtype2->check(1), 'Correctly passed'; |
50 | ok ! $subtype2->check('a'), 'correctly failed'; |
51 | ok ! $subtype2->check(100), 'correctly failed'; |
52 | |
53 | ok $subtype2->my_custom_method, 'found the custom method'; |
54 | |
55 | |
56 | { |
57 | package Foo; |
58 | |
59 | use Mouse; |
60 | } |
61 | |
62 | { |
63 | package Bar; |
64 | |
65 | use Mouse; |
66 | |
67 | extends 'Foo'; |
68 | } |
69 | |
70 | { |
71 | package Baz; |
72 | |
73 | use Mouse; |
74 | } |
75 | |
76 | my $foo = class_type 'Foo'; |
77 | my $isa_foo = subtype 'IsaFoo' => as $foo; |
78 | |
79 | ok $isa_foo, 'Created subtype of Foo type'; |
80 | ok $isa_foo->check( Foo->new ), 'Foo passes check'; |
81 | ok $isa_foo->check( Bar->new ), 'Bar passes check'; |
82 | ok ! $isa_foo->check( Baz->new ), 'Baz does not pass check'; |
83 | like $foo->get_message( Baz->new ), qr/^Validation failed for 'Foo' failed with value Baz=HASH\(0x\w+\) \(not isa Foo\)/, 'Better validation message'; |
84 | |
85 | # Maybe in the future this *should* inherit? |
86 | like $isa_foo->get_message( Baz->new ), qr/^Validation failed for 'IsaFoo' failed with value Baz=HASH\(0x\w+\)$/, "Subtypes do not automatically inherit parent type's message"; |
87 | |
88 | |
89 | # Implicit types |
90 | { |
91 | package Quux; |
92 | |
93 | use Mouse; |
94 | |
95 | has age => ( |
96 | isa => 'Positive', |
97 | is => 'bare', |
98 | ); |
99 | } |
100 | |
101 | throws_ok { |
102 | Quux->new(age => 3) |
103 | } qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' failed with value 3 \(not isa Positive\)/; |
104 | |
105 | lives_ok { |
106 | Quux->new(age => (bless {}, 'Positive')); |
107 | }; |
108 | |
109 | eval " |
110 | package Positive; |
111 | use Mouse; |
112 | "; |
113 | |
114 | throws_ok { |
115 | Quux->new(age => 3) |
116 | } qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' failed with value 3 \(not isa Positive\)/; |
117 | |
118 | lives_ok { |
119 | Quux->new(age => Positive->new) |
120 | }; |
121 | |
122 | class_type 'Negative' => message { "$_ is not a Negative Nancy" }; |
123 | |
124 | { |
125 | package Quux::Ier; |
126 | |
127 | use Mouse; |
128 | |
129 | has age => ( |
130 | isa => 'Negative', |
131 | is => 'bare', |
132 | ); |
133 | } |
134 | |
135 | throws_ok { |
136 | Quux::Ier->new(age => 3) |
137 | } qr/^Attribute \(age\) does not pass the type constraint because: 3 is not a Negative Nancy /; |
138 | |
139 | lives_ok { |
140 | Quux::Ier->new(age => (bless {}, 'Negative')) |
141 | }; |