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