also use Eval::Closure in the test
[gitmo/Moose.git] / lib / Moose / Meta / TypeConstraint.pm
CommitLineData
4e036ee4 1
2package Moose::Meta::TypeConstraint;
3
4use strict;
5use warnings;
6use metaclass;
7
ed90007b 8use overload '0+' => sub { refaddr(shift) }, # id an object
9 '""' => sub { shift->name }, # stringify to tc name
72e389bf 10 bool => sub { 1 },
b644e331 11 fallback => 1;
900466d6 12
477a812e 13use Eval::Closure;
dabed765 14use Scalar::Util qw(blessed refaddr);
9f2230e9 15use Sub::Name qw(subname);
5a18346b 16use Try::Tiny;
66811d63 17
e606ae5f 18use base qw(Class::MOP::Object);
19
3726f905 20__PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
21__PACKAGE__->meta->add_attribute('parent' => (
22 reader => 'parent',
23 predicate => 'has_parent',
24));
baf26cc6 25
26my $null_constraint = sub { 1 };
d67145ed 27__PACKAGE__->meta->add_attribute('constraint' => (
8de73ff1 28 reader => 'constraint',
29 writer => '_set_constraint',
baf26cc6 30 default => sub { $null_constraint }
d67145ed 31));
76d37e5a 32__PACKAGE__->meta->add_attribute('message' => (
33 accessor => 'message',
34 predicate => 'has_message'
35));
a27aa600 36__PACKAGE__->meta->add_attribute('coercion' => (
37 accessor => 'coercion',
38 predicate => 'has_coercion'
39));
70ea9161 40
c8cf9aaa 41__PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
42 init_arg => 'optimized',
43 accessor => 'hand_optimized_type_constraint',
e27dfc11 44 predicate => 'has_hand_optimized_type_constraint',
c8cf9aaa 45));
46
4e36cf24 47__PACKAGE__->meta->add_attribute('inlined' => (
7487e61c 48 init_arg => 'inlined',
4e36cf24 49 accessor => 'inlined',
7487e61c 50 predicate => '_has_inlined_type_constraint',
4e36cf24 51));
52
bd72f3c8 53sub parents {
54 my $self;
55 $self->parent;
56}
57
3726f905 58# private accessors
59
60__PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
61 accessor => '_compiled_type_constraint',
62 predicate => '_has_compiled_type_constraint'
63));
22aed3c0 64__PACKAGE__->meta->add_attribute('package_defined_in' => (
65 accessor => '_package_defined_in'
66));
67
e27dfc11 68sub new {
a27aa600 69 my $class = shift;
8534c69a 70 my ($first, @rest) = @_;
71 my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
72 $args{name} = $args{name} ? "$args{name}" : "__ANON__";
70ea9161 73
8534c69a 74 my $self = $class->_new(%args);
3726f905 75 $self->compile_type_constraint()
76 unless $self->_has_compiled_type_constraint;
66811d63 77 return $self;
78}
79
8534c69a 80
81
70ea9161 82sub coerce {
83 my $self = shift;
84
85 my $coercion = $self->coercion;
86
87 unless ($coercion) {
88 require Moose;
89 Moose->throw_error("Cannot coerce without a type coercion");
90 }
91
02679ba4 92 return $_[0] if $self->check($_[0]);
93
70ea9161 94 return $coercion->coerce(@_);
95}
a1257460 96
bb6ac54a 97sub assert_coerce {
98 my $self = shift;
99
100 my $coercion = $self->coercion;
101
102 unless ($coercion) {
103 require Moose;
104 Moose->throw_error("Cannot coerce without a type coercion");
105 }
106
107 return $_[0] if $self->check($_[0]);
108
109 my $result = $coercion->coerce(@_);
110
111 $self->assert_valid($result);
112
113 return $result;
114}
115
a1257460 116sub check {
117 my ($self, @args) = @_;
118 my $constraint_subref = $self->_compiled_type_constraint;
119 return $constraint_subref->(@args) ? 1 : undef;
120}
121
e27dfc11 122sub validate {
76d37e5a 123 my ($self, $value) = @_;
124 if ($self->_compiled_type_constraint->($value)) {
125 return undef;
126 }
127 else {
688fcdda 128 $self->get_message($value);
76d37e5a 129 }
130}
131
7487e61c 132sub has_inlined_type_constraint {
133 my $self = shift;
134
92efe680 135 if ( $self->has_parent && $self->constraint == $null_constraint ) {
7487e61c 136 return $self->parent->has_inlined_type_constraint;
137 }
138
139 return $self->_has_inlined_type_constraint;
140}
141
4e36cf24 142sub _inline_check {
143 my $self = shift;
144
3f9c18f3 145 unless ( $self->has_inlined_type_constraint ) {
146 require Moose;
147 Moose->throw_error( 'Cannot inline a type constraint check for ' . $self->name );
148 }
4e36cf24 149
92efe680 150 if ( $self->has_parent && $self->constraint == $null_constraint ) {
7487e61c 151 return $self->parent->_inline_check(@_);
152 }
153
964294c1 154 return $self->inlined->( $self, @_ );
4e36cf24 155}
156
c24269b3 157sub assert_valid {
158 my ($self, $value) = @_;
159
160 my $error = $self->validate($value);
161 return 1 if ! defined $error;
162
163 require Moose;
164 Moose->throw_error($error);
165}
166
688fcdda 167sub get_message {
168 my ($self, $value) = @_;
688fcdda 169 if (my $msg = $self->message) {
170 local $_ = $value;
171 return $msg->($value);
172 }
173 else {
5a18346b 174 # have to load it late like this, since it uses Moose itself
a1829d2f 175 my $can_partialdump = try {
176 # versions prior to 0.14 had a potential infinite loop bug
177 Class::MOP::load_class('Devel::PartialDump', { -version => 0.14 });
178 1;
179 };
180 if ($can_partialdump) {
5a18346b 181 $value = Devel::PartialDump->new->dump($value);
182 }
183 else {
184 $value = (defined $value ? overload::StrVal($value) : 'undef');
185 }
24a9f75e 186 return "Validation failed for '" . $self->name . "' with value $value";
d03bd989 187 }
688fcdda 188}
189
3726f905 190## type predicates ...
191
d9e17f80 192sub equals {
193 my ( $self, $type_or_name ) = @_;
194
e606ae5f 195 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
dabed765 196
0677975f 197 return 1 if $self == $other;
dabed765 198
199 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
200 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
201 }
202
203 return unless $self->constraint == $other->constraint;
204
205 if ( $self->has_parent ) {
206 return unless $other->has_parent;
207 return unless $self->parent->equals( $other->parent );
208 } else {
209 return if $other->has_parent;
210 }
d9e17f80 211
05a5763c 212 return;
d9e17f80 213}
214
b26e162e 215sub is_a_type_of {
d9e17f80 216 my ($self, $type_or_name) = @_;
217
e606ae5f 218 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
d9e17f80 219
220 ($self->equals($type) || $self->is_subtype_of($type));
b26e162e 221}
222
cce8198b 223sub is_subtype_of {
d9e17f80 224 my ($self, $type_or_name) = @_;
225
e606ae5f 226 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
d9e17f80 227
cce8198b 228 my $current = $self;
d9e17f80 229
cce8198b 230 while (my $parent = $current->parent) {
d9e17f80 231 return 1 if $parent->equals($type);
cce8198b 232 $current = $parent;
233 }
d9e17f80 234
cce8198b 235 return 0;
236}
237
3726f905 238## compiling the type constraint
239
240sub compile_type_constraint {
241 my $self = shift;
242 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
451c8248 243}
244
3726f905 245## type compilers ...
246
247sub _actually_compile_type_constraint {
248 my $self = shift;
e27dfc11 249
3726f905 250 return $self->_compile_hand_optimized_type_constraint
251 if $self->has_hand_optimized_type_constraint;
e27dfc11 252
43837b8a 253 if ( $self->has_inlined_type_constraint ) {
477a812e 254 return eval_closure(
255 source => 'sub { ' . $self->_inline_check('$_[0]') . ' }',
256 );
43837b8a 257 }
258
3726f905 259 my $check = $self->constraint;
70ea9161 260 unless ( defined $check ) {
261 require Moose;
262 Moose->throw_error( "Could not compile type constraint '"
e27dfc11 263 . $self->name
70ea9161 264 . "' because no constraint check" );
265 }
e27dfc11 266
3726f905 267 return $self->_compile_subtype($check)
268 if $self->has_parent;
e27dfc11 269
3726f905 270 return $self->_compile_type($check);
271}
272
273sub _compile_hand_optimized_type_constraint {
274 my $self = shift;
e27dfc11 275
3726f905 276 my $type_constraint = $self->hand_optimized_type_constraint;
e27dfc11 277
70ea9161 278 unless ( ref $type_constraint ) {
279 require Moose;
70ea9161 280 Moose->throw_error("Hand optimized type constraint is not a code reference");
281 }
42bc21a4 282
283 return $type_constraint;
3726f905 284}
285
286sub _compile_subtype {
287 my ($self, $check) = @_;
e27dfc11 288
baf26cc6 289 # gather all the parent constraintss in order
3726f905 290 my @parents;
baf26cc6 291 my $optimized_parent;
3726f905 292 foreach my $parent ($self->_collect_all_parents) {
baf26cc6 293 # if a parent is optimized, the optimized constraint already includes
294 # all of its parents tcs, so we can break the loop
3726f905 295 if ($parent->has_hand_optimized_type_constraint) {
baf26cc6 296 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
e27dfc11 297 last;
3726f905 298 }
299 else {
baf26cc6 300 push @parents => $parent->constraint;
3726f905 301 }
302 }
e27dfc11 303
baf26cc6 304 @parents = grep { $_ != $null_constraint } reverse @parents;
305
306 unless ( @parents ) {
307 return $self->_compile_type($check);
308 } elsif( $optimized_parent and @parents == 1 ) {
309 # the case of just one optimized parent is optimized to prevent
310 # looping and the unnecessary localization
b5981f07 311 if ( $check == $null_constraint ) {
312 return $optimized_parent;
313 } else {
9f2230e9 314 return subname($self->name, sub {
b5981f07 315 return undef unless $optimized_parent->($_[0]);
a1257460 316 my (@args) = @_;
317 local $_ = $args[0];
318 $check->(@args);
b5981f07 319 });
320 }
baf26cc6 321 } else {
322 # general case, check all the constraints, from the first parent to ourselves
b5981f07 323 my @checks = @parents;
324 push @checks, $check if $check != $null_constraint;
9f2230e9 325 return subname($self->name => sub {
a1257460 326 my (@args) = @_;
327 local $_ = $args[0];
baf26cc6 328 foreach my $check (@checks) {
a1257460 329 return undef unless $check->(@args);
baf26cc6 330 }
331 return 1;
332 });
333 }
3726f905 334}
335
336sub _compile_type {
337 my ($self, $check) = @_;
baf26cc6 338
339 return $check if $check == $null_constraint; # Item, Any
340
9f2230e9 341 return subname($self->name => sub {
a1257460 342 my (@args) = @_;
343 local $_ = $args[0];
344 $check->(@args);
1b2aea39 345 });
3726f905 346}
347
348## other utils ...
349
350sub _collect_all_parents {
351 my $self = shift;
352 my @parents;
353 my $current = $self->parent;
354 while (defined $current) {
355 push @parents => $current;
356 $current = $current->parent;
357 }
358 return @parents;
359}
360
85a9908f 361sub create_child_type {
9ceb576e 362 my ($self, %opts) = @_;
363 my $class = ref $self;
364 return $class->new(%opts, parent => $self);
365}
366
4e036ee4 3671;
368
ad46f524 369# ABSTRACT: The Moose Type Constraint metaclass
370
4e036ee4 371__END__
372
373=pod
374
4e036ee4 375=head1 DESCRIPTION
376
cfd006f0 377This class represents a single type constraint. Moose's built-in type
76127c77 378constraints, as well as constraints you define, are all stored in a
cfd006f0 379L<Moose::Meta::TypeConstraint::Registry> object as objects of this
380class.
6ba6d68c 381
baf46b9e 382=head1 INHERITANCE
383
384C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
385
4e036ee4 386=head1 METHODS
387
388=over 4
389
cfd006f0 390=item B<< Moose::Meta::TypeConstraint->new(%options) >>
4e036ee4 391
cfd006f0 392This creates a new type constraint based on the provided C<%options>:
4e036ee4 393
cfd006f0 394=over 8
d9e17f80 395
cfd006f0 396=item * name
e606ae5f 397
cfd006f0 398The constraint name. If a name is not provided, it will be set to
399"__ANON__".
b26e162e 400
cfd006f0 401=item * parent
b26e162e 402
cfd006f0 403A C<Moose::Meta::TypeConstraint> object which is the parent type for
404the type being created. This is optional.
cce8198b 405
cfd006f0 406=item * constraint
e606ae5f 407
cfd006f0 408This is the subroutine reference that implements the actual constraint
409check. This defaults to a subroutine which always returns true.
6ba6d68c 410
cfd006f0 411=item * message
0a5bd159 412
cfd006f0 413A subroutine reference which is used to generate an error message when
414the constraint fails. This is optional.
0a5bd159 415
cfd006f0 416=item * coercion
76d37e5a 417
cfd006f0 418A L<Moose::Meta::TypeCoercion> object representing the coercions to
419the type. This is optional.
76d37e5a 420
cfd006f0 421=item * optimized
76d37e5a 422
cfd006f0 423This is a variant of the C<constraint> parameter that is somehow
424optimized. Typically, this means incorporating both the type's
425constraint and all of its parents' constraints into a single
426subroutine reference.
6ba6d68c 427
cfd006f0 428=back
4e036ee4 429
cfd006f0 430=item B<< $constraint->equals($type_name_or_object) >>
e606ae5f 431
cfd006f0 432Returns true if the supplied name or type object is the same as the
433current type.
66811d63 434
cfd006f0 435=item B<< $constraint->is_subtype_of($type_name_or_object) >>
e606ae5f 436
cfd006f0 437Returns true if the supplied name or type object is a parent of the
438current type.
3726f905 439
cfd006f0 440=item B<< $constraint->is_a_type_of($type_name_or_object) >>
e606ae5f 441
cfd006f0 442Returns true if the given type is the same as the current type, or is
443a parent of the current type. This is a shortcut for checking
444C<equals> and C<is_subtype_of>.
d9e17f80 445
cfd006f0 446=item B<< $constraint->coerce($value) >>
2f7e4042 447
b2894aea 448This will attempt to coerce the value to the type. If the type does not
cfd006f0 449have any defined coercions this will throw an error.
66811d63 450
572b5187 451If no coercion can produce a value matching C<$constraint>, the original
452value is returned.
453
086c6b6c 454=item B<< $constraint->assert_coerce($value) >>
572b5187 455
456This method behaves just like C<coerce>, but if the result is not valid
457according to C<$constraint>, an error is thrown.
458
cfd006f0 459=item B<< $constraint->check($value) >>
2f7e4042 460
cfd006f0 461Returns true if the given value passes the constraint for the type.
76d37e5a 462
cfd006f0 463=item B<< $constraint->validate($value) >>
2f7e4042 464
cfd006f0 465This is similar to C<check>. However, if the type I<is valid> then the
466method returns an explicit C<undef>. If the type is not valid, we call
467C<< $self->get_message($value) >> internally to generate an error
468message.
76d37e5a 469
952320e0 470=item B<< $constraint->assert_valid($value) >>
471
472Like C<check> and C<validate>, this method checks whether C<$value> is
473valid under the constraint. If it is, it will return true. If it is not,
474an exception will be thrown with the results of
475C<< $self->get_message($value) >>.
476
cfd006f0 477=item B<< $constraint->name >>
2f7e4042 478
cfd006f0 479Returns the type's name, as provided to the constructor.
688fcdda 480
cfd006f0 481=item B<< $constraint->parent >>
2f7e4042 482
cfd006f0 483Returns the type's parent, as provided to the constructor, if any.
4e036ee4 484
cfd006f0 485=item B<< $constraint->has_parent >>
2f7e4042 486
cfd006f0 487Returns true if the type has a parent type.
a27aa600 488
cfd006f0 489=item B<< $constraint->parents >>
2f7e4042 490
cfd006f0 491A synonym for C<parent>. This is useful for polymorphism with types
492that can have more than one parent.
c8cf9aaa 493
cfd006f0 494=item B<< $constraint->constraint >>
c8cf9aaa 495
cfd006f0 496Returns the type's constraint, as provided to the constructor.
9ceb576e 497
cfd006f0 498=item B<< $constraint->get_message($value) >>
4e036ee4 499
cfd006f0 500This generates a method for the given value. If the type does not have
501an explicit message, we generate a default message.
3726f905 502
cfd006f0 503=item B<< $constraint->has_message >>
504
505Returns true if the type has a message.
506
507=item B<< $constraint->message >>
508
509Returns the type's message as a subroutine reference.
510
511=item B<< $constraint->coercion >>
512
513Returns the type's L<Moose::Meta::TypeCoercion> object, if one
514exists.
515
516=item B<< $constraint->has_coercion >>
517
518Returns true if the type has a coercion.
519
520=item B<< $constraint->hand_optimized_type_constraint >>
521
522Returns the type's hand optimized constraint, as provided to the
523constructor via the C<optimized> option.
524
525=item B<< $constraint->has_hand_optimized_type_constraint >>
526
527Returns true if the type has an optimized constraint.
528
529=item B<< $constraint->create_child_type(%options) >>
451c8248 530
cfd006f0 531This returns a new type constraint of the same class using the
532provided C<%options>. The C<parent> option will be the current type.
3726f905 533
cfd006f0 534This method exists so that subclasses of this class can override this
535behavior and change how child types are created.
451c8248 536
537=back
538
4e036ee4 539=head1 BUGS
540
d4048ef3 541See L<Moose/BUGS> for details on reporting bugs.
4e036ee4 542
c8cf9aaa 543=cut