Commit | Line | Data |
a15dff8d |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
a28e50e4 |
6 | use Test::More; |
b10dde3a |
7 | use Test::Fatal; |
a15dff8d |
8 | |
9 | use Scalar::Util (); |
10 | |
e3979c3e |
11 | use Moose::Util::TypeConstraints; |
12 | |
a15dff8d |
13 | |
5a4c5493 |
14 | type Number => where { Scalar::Util::looks_like_number($_) }; |
d03bd989 |
15 | type String |
c899258b |
16 | => where { !ref($_) && !Number($_) } |
17 | => message { "This is not a string ($_)" }; |
a15dff8d |
18 | |
d03bd989 |
19 | subtype Natural |
20 | => as Number |
4ed9b9b4 |
21 | => where { $_ > 0 }; |
a15dff8d |
22 | |
d03bd989 |
23 | subtype NaturalLessThanTen |
4ed9b9b4 |
24 | => as Natural |
25 | => where { $_ < 10 } |
26 | => message { "The number '$_' is not less than 10" }; |
d03bd989 |
27 | |
d9b40005 |
28 | Moose::Util::TypeConstraints->export_type_constraints_as_functions(); |
a15dff8d |
29 | |
5a4c5493 |
30 | ok(Number(5), '... this is a Num'); |
31 | ok(!defined(Number('Foo')), '... this is not a Num'); |
900466d6 |
32 | { |
33 | my $number_tc = Moose::Util::TypeConstraints::find_type_constraint('Number'); |
b644e331 |
34 | is("$number_tc", 'Number', '... type constraint stringifies to name'); |
900466d6 |
35 | } |
a15dff8d |
36 | |
5a4c5493 |
37 | ok(String('Foo'), '... this is a Str'); |
a15dff8d |
38 | ok(!defined(String(5)), '... this is not a Str'); |
39 | |
5a4c5493 |
40 | ok(Natural(5), '... this is a Natural'); |
a15dff8d |
41 | is(Natural(-5), undef, '... this is not a Natural'); |
42 | is(Natural('Foo'), undef, '... this is not a Natural'); |
43 | |
5a4c5493 |
44 | ok(NaturalLessThanTen(5), '... this is a NaturalLessThanTen'); |
a15dff8d |
45 | is(NaturalLessThanTen(12), undef, '... this is not a NaturalLessThanTen'); |
46 | is(NaturalLessThanTen(-5), undef, '... this is not a NaturalLessThanTen'); |
47 | is(NaturalLessThanTen('Foo'), undef, '... this is not a NaturalLessThanTen'); |
d03bd989 |
48 | |
49 | # anon sub-typing |
50 | |
4ed9b9b4 |
51 | my $negative = subtype Number => where { $_ < 0 }; |
a15dff8d |
52 | ok(defined $negative, '... got a value back from negative'); |
66811d63 |
53 | isa_ok($negative, 'Moose::Meta::TypeConstraint'); |
a15dff8d |
54 | |
5a4c5493 |
55 | ok($negative->check(-5), '... this is a negative number'); |
a27aa600 |
56 | ok(!defined($negative->check(5)), '... this is not a negative number'); |
57 | is($negative->check('Foo'), undef, '... this is not a negative number'); |
58 | |
cce8198b |
59 | ok($negative->is_subtype_of('Number'), '... $negative is a subtype of Number'); |
60 | ok(!$negative->is_subtype_of('String'), '... $negative is not a subtype of String'); |
61 | |
e3979c3e |
62 | my $negative2 = subtype Number => where { $_ < 0 } => message {"$_ is not a negative number"}; |
63 | |
64 | ok(defined $negative2, '... got a value back from negative'); |
65 | isa_ok($negative2, 'Moose::Meta::TypeConstraint'); |
66 | |
67 | ok($negative2->check(-5), '... this is a negative number'); |
68 | ok(!defined($negative2->check(5)), '... this is not a negative number'); |
69 | is($negative2->check('Foo'), undef, '... this is not a negative number'); |
70 | |
71 | ok($negative2->is_subtype_of('Number'), '... $negative2 is a subtype of Number'); |
72 | ok(!$negative2->is_subtype_of('String'), '... $negative is not a subtype of String'); |
73 | |
74 | ok($negative2->has_message, '... it has a message'); |
d03bd989 |
75 | is($negative2->validate(2), |
e3979c3e |
76 | '2 is not a negative number', |
77 | '... validated unsuccessfully (got error)'); |
78 | |
76d37e5a |
79 | # check some meta-details |
80 | |
81 | my $natural_less_than_ten = find_type_constraint('NaturalLessThanTen'); |
82 | isa_ok($natural_less_than_ten, 'Moose::Meta::TypeConstraint'); |
83 | |
cce8198b |
84 | ok($natural_less_than_ten->is_subtype_of('Natural'), '... NaturalLessThanTen is subtype of Natural'); |
85 | ok($natural_less_than_ten->is_subtype_of('Number'), '... NaturalLessThanTen is subtype of Number'); |
86 | ok(!$natural_less_than_ten->is_subtype_of('String'), '... NaturalLessThanTen is not subtype of String'); |
87 | |
76d37e5a |
88 | ok($natural_less_than_ten->has_message, '... it has a message'); |
89 | |
90 | ok(!defined($natural_less_than_ten->validate(5)), '... validated successfully (no error)'); |
91 | |
d03bd989 |
92 | is($natural_less_than_ten->validate(15), |
93 | "The number '15' is not less than 10", |
76d37e5a |
94 | '... validated unsuccessfully (got error)'); |
95 | |
96 | my $natural = find_type_constraint('Natural'); |
97 | isa_ok($natural, 'Moose::Meta::TypeConstraint'); |
98 | |
cce8198b |
99 | ok($natural->is_subtype_of('Number'), '... Natural is a subtype of Number'); |
100 | ok(!$natural->is_subtype_of('String'), '... Natural is not a subtype of String'); |
101 | |
76d37e5a |
102 | ok(!$natural->has_message, '... it does not have a message'); |
103 | |
104 | ok(!defined($natural->validate(5)), '... validated successfully (no error)'); |
105 | |
d03bd989 |
106 | is($natural->validate(-5), |
8c063f8e |
107 | "Validation failed for 'Natural' with value -5", |
76d37e5a |
108 | '... validated unsuccessfully (got error)'); |
a27aa600 |
109 | |
c899258b |
110 | my $string = find_type_constraint('String'); |
111 | isa_ok($string, 'Moose::Meta::TypeConstraint'); |
a27aa600 |
112 | |
c899258b |
113 | ok($string->has_message, '... it does have a message'); |
114 | |
115 | ok(!defined($string->validate("Five")), '... validated successfully (no error)'); |
116 | |
d03bd989 |
117 | is($string->validate(5), |
118 | "This is not a string (5)", |
c899258b |
119 | '... validated unsuccessfully (got error)'); |
8c4acc60 |
120 | |
b10dde3a |
121 | is( exception { Moose::Meta::Attribute->new('bob', isa => 'Spong') }, undef, 'meta-attr construction ok even when type constraint utils loaded first' ); |
9758af8a |
122 | |
123 | # Test type constraint predicate return values. |
124 | |
125 | foreach my $predicate (qw/equals is_subtype_of is_a_type_of/) { |
126 | ok( !defined $string->$predicate('DoesNotExist'), "$predicate predicate returns undef for non existant constraint"); |
127 | } |
128 | |
129 | # Test adding things which don't look like types to the registry throws an exception |
130 | |
131 | my $r = Moose::Util::TypeConstraints->get_type_constraint_registry; |
b10dde3a |
132 | like( exception {$r->add_type_constraint()}, qr/not a valid type constraint/, '->add_type_constraint(undef) throws' ); |
133 | like( exception {$r->add_type_constraint('foo')}, qr/not a valid type constraint/, '->add_type_constraint("foo") throws' ); |
134 | like( exception {$r->add_type_constraint(bless {}, 'SomeClass')}, qr/not a valid type constraint/, '->add_type_constraint(SomeClass->new) throws' ); |
9758af8a |
135 | |
9a63faba |
136 | # Test some specific things that in the past did not work, |
137 | # specifically weird variations on anon subtypes. |
138 | |
139 | { |
140 | my $subtype = subtype as 'Str'; |
141 | isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' ); |
142 | is( $subtype->parent->name, 'Str', 'parent is Str' ); |
143 | # This test sucks but is the best we can do |
144 | is( $subtype->constraint->(), 1, |
145 | 'subtype has the null constraint' ); |
146 | ok( ! $subtype->has_message, 'subtype has no message' ); |
147 | } |
148 | |
149 | { |
f75f625d |
150 | my $subtype = subtype as 'ArrayRef[Num|Str]'; |
9a63faba |
151 | isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' ); |
152 | is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' ); |
153 | ok( ! $subtype->has_message, 'subtype has no message' ); |
154 | } |
155 | |
156 | { |
157 | my $subtype = subtype 'ArrayRef[Num|Str]' => message { 'foo' }; |
158 | isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' ); |
159 | is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' ); |
160 | ok( $subtype->has_message, 'subtype does have a message' ); |
161 | } |
162 | |
9e856c83 |
163 | # alternative sugar-less calling style which is documented as legit: |
164 | { |
165 | my $subtype = subtype( 'MyStr', { as => 'Str' } ); |
166 | isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); |
167 | is( $subtype->name, 'MyStr', 'name is MyStr' ); |
168 | is( $subtype->parent->name, 'Str', 'parent is Str' ); |
169 | } |
170 | |
171 | { |
172 | my $subtype = subtype( { as => 'Str' } ); |
173 | isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); |
174 | is( $subtype->name, '__ANON__', 'name is __ANON__' ); |
175 | is( $subtype->parent->name, 'Str', 'parent is Str' ); |
176 | } |
177 | |
178 | { |
179 | my $subtype = subtype( { as => 'Str', where => sub { /X/ } } ); |
180 | isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); |
181 | is( $subtype->name, '__ANON__', 'name is __ANON__' ); |
182 | is( $subtype->parent->name, 'Str', 'parent is Str' ); |
183 | ok( $subtype->check('FooX'), 'constraint accepts FooX' ); |
184 | ok( ! $subtype->check('Foo'), 'constraint reject Foo' ); |
185 | } |
186 | |
f75f625d |
187 | { |
b10dde3a |
188 | like( exception { subtype 'Foo' }, qr/cannot consist solely of a name/, 'Cannot call subtype with a single string argument' ); |
f75f625d |
189 | } |
9e856c83 |
190 | |
9a63faba |
191 | # Back-compat for being called without sugar. Previously, calling with |
192 | # sugar was indistinguishable from calling directly. |
193 | |
194 | { |
44193bda |
195 | no warnings 'redefine'; |
196 | *Moose::Deprecated::deprecated = sub { return }; |
197 | } |
198 | |
199 | { |
9a63faba |
200 | my $type = type( 'Number2', sub { Scalar::Util::looks_like_number($_) } ); |
201 | |
202 | ok( $type->check(5), '... this is a Num' ); |
203 | ok( ! $type->check('Foo'), '... this is not a Num' ); |
204 | } |
205 | |
206 | { |
207 | # anon subtype |
208 | my $subtype = subtype( 'Number2', sub { $_ > 0 } ); |
209 | |
210 | ok( $subtype->check(5), '... this is a Natural'); |
211 | ok( ! $subtype->check(-5), '... this is not a Natural'); |
212 | ok( ! $subtype->check('Foo'), '... this is not a Natural'); |
213 | } |
214 | |
215 | { |
216 | my $subtype = subtype( 'Natural2', 'Number2', sub { $_ > 0 } ); |
217 | |
218 | ok( $subtype->check(5), '... this is a Natural'); |
219 | ok( ! $subtype->check(-5), '... this is not a Natural'); |
220 | ok( ! $subtype->check('Foo'), '... this is not a Natural'); |
221 | } |
222 | |
223 | { |
224 | my $subtype = subtype( 'Natural3', 'Number2' ); |
225 | |
226 | ok( $subtype->check(5), '... this is a Natural'); |
227 | ok( $subtype->check(-5), '... this is a Natural'); |
228 | ok( ! $subtype->check('Foo'), '... this is not a Natural'); |
229 | } |
230 | |
a28e50e4 |
231 | done_testing; |