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