Commit | Line | Data |
9ceb576e |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
a28e50e4 |
6 | use Test::More; |
b10dde3a |
7 | use Test::Fatal; |
9ceb576e |
8 | |
81e727db |
9 | use Moose::Util::TypeConstraints; |
10 | use Moose::Meta::TypeConstraint; |
11 | |
9ceb576e |
12 | |
13 | ## Create a subclass with a custom method |
14 | |
15 | { |
16 | package Test::Moose::Meta::TypeConstraint::AnySubType; |
17 | use Moose; |
18 | extends 'Moose::Meta::TypeConstraint'; |
d03bd989 |
19 | |
9ceb576e |
20 | sub my_custom_method { |
21 | return 1; |
22 | } |
23 | } |
24 | |
81e727db |
25 | my $Int = find_type_constraint('Int'); |
e7e0942b |
26 | ok $Int, 'Got a good type constraint'; |
9ceb576e |
27 | |
28 | my $parent = Test::Moose::Meta::TypeConstraint::AnySubType->new({ |
46fdd900 |
29 | name => "Test::Moose::Meta::TypeConstraint::AnySubType" , |
30 | parent => $Int, |
9ceb576e |
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 | |
81e727db |
38 | my $subtype1 = subtype 'another_subtype' => as $parent; |
9ceb576e |
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 | |
81e727db |
46 | my $subtype2 = subtype 'another_subtype' => as $subtype1 => where { $_ < 10 }; |
9ceb576e |
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 | |
81e727db |
53 | ok $subtype2->my_custom_method, 'found the custom method'; |
54 | |
55 | |
56 | { |
57 | package Foo; |
58 | |
59 | use Moose; |
60 | } |
61 | |
62 | { |
63 | package Bar; |
64 | |
65 | use Moose; |
66 | |
67 | extends 'Foo'; |
68 | } |
69 | |
70 | { |
71 | package Baz; |
72 | |
73 | use Moose; |
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'; |
8c063f8e |
83 | like $foo->get_message( Baz->new ), qr/^Validation failed for 'Foo' with value Baz=HASH\(0x\w+\) \(not isa Foo\)/, 'Better validation message'; |
d414e17c |
84 | |
85 | # Maybe in the future this *should* inherit? |
8c063f8e |
86 | like $isa_foo->get_message( Baz->new ), qr/^Validation failed for 'IsaFoo' with value Baz=HASH\(0x\w+\)$/, "Subtypes do not automatically inherit parent type's message"; |
d414e17c |
87 | |
88 | |
89 | # Implicit types |
90 | { |
91 | package Quux; |
92 | |
93 | use Moose; |
94 | |
95 | has age => ( |
96 | isa => 'Positive', |
ccd4cff9 |
97 | is => 'bare', |
d414e17c |
98 | ); |
99 | } |
100 | |
b10dde3a |
101 | like( exception { |
d414e17c |
102 | Quux->new(age => 3) |
b10dde3a |
103 | }, qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' with value 3 \(not isa Positive\)/ ); |
d414e17c |
104 | |
b10dde3a |
105 | is( exception { |
d414e17c |
106 | Quux->new(age => (bless {}, 'Positive')); |
b10dde3a |
107 | }, undef ); |
d414e17c |
108 | |
109 | eval " |
110 | package Positive; |
111 | use Moose; |
112 | "; |
113 | |
b10dde3a |
114 | like( exception { |
d414e17c |
115 | Quux->new(age => 3) |
b10dde3a |
116 | }, qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' with value 3 \(not isa Positive\)/ ); |
d414e17c |
117 | |
b10dde3a |
118 | is( exception { |
d414e17c |
119 | Quux->new(age => Positive->new) |
b10dde3a |
120 | }, undef ); |
d414e17c |
121 | |
122 | class_type 'Negative' => message { "$_ is not a Negative Nancy" }; |
123 | |
124 | { |
125 | package Quux::Ier; |
126 | |
127 | use Moose; |
128 | |
129 | has age => ( |
130 | isa => 'Negative', |
ccd4cff9 |
131 | is => 'bare', |
d414e17c |
132 | ); |
133 | } |
134 | |
b10dde3a |
135 | like( exception { |
d414e17c |
136 | Quux::Ier->new(age => 3) |
b10dde3a |
137 | }, qr/^Attribute \(age\) does not pass the type constraint because: 3 is not a Negative Nancy / ); |
d414e17c |
138 | |
b10dde3a |
139 | is( exception { |
d414e17c |
140 | Quux::Ier->new(age => (bless {}, 'Negative')) |
b10dde3a |
141 | }, undef ); |
a28e50e4 |
142 | |
143 | done_testing; |