2 package Moose::Meta::TypeConstraint;
8 use overload '""' => sub { shift->name }, # stringify to tc name
11 use Scalar::Util qw(blessed refaddr);
13 use base qw(Class::MOP::Object);
15 our $VERSION = '0.75_01';
16 $VERSION = eval $VERSION;
17 our $AUTHORITY = 'cpan:STEVAN';
19 __PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
20 __PACKAGE__->meta->add_attribute('parent' => (
22 predicate => 'has_parent',
25 my $null_constraint = sub { 1 };
26 __PACKAGE__->meta->add_attribute('constraint' => (
27 reader => 'constraint',
28 writer => '_set_constraint',
29 default => sub { $null_constraint }
31 __PACKAGE__->meta->add_attribute('message' => (
32 accessor => 'message',
33 predicate => 'has_message'
35 __PACKAGE__->meta->add_attribute('coercion' => (
36 accessor => 'coercion',
37 predicate => 'has_coercion'
40 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
41 init_arg => 'optimized',
42 accessor => 'hand_optimized_type_constraint',
43 predicate => 'has_hand_optimized_type_constraint',
53 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
54 accessor => '_compiled_type_constraint',
55 predicate => '_has_compiled_type_constraint'
57 __PACKAGE__->meta->add_attribute('package_defined_in' => (
58 accessor => '_package_defined_in'
63 my ($first, @rest) = @_;
64 my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
65 $args{name} = $args{name} ? "$args{name}" : "__ANON__";
67 my $self = $class->_new(%args);
68 $self->compile_type_constraint()
69 unless $self->_has_compiled_type_constraint;
78 my $coercion = $self->coercion;
82 Moose->throw_error("Cannot coerce without a type coercion");
85 return $_[0] if $self->check($_[0]);
87 return $coercion->coerce(@_);
91 my ($self, @args) = @_;
92 my $constraint_subref = $self->_compiled_type_constraint;
93 return $constraint_subref->(@args) ? 1 : undef;
97 my ($self, $value) = @_;
98 if ($self->_compiled_type_constraint->($value)) {
102 $self->get_message($value);
107 my ($self, $value) = @_;
108 if (my $msg = $self->message) {
110 return $msg->($value);
113 $value = (defined $value ? overload::StrVal($value) : 'undef');
114 return "Validation failed for '" . $self->name . "' failed with value $value";
118 ## type predicates ...
121 my ( $self, $type_or_name ) = @_;
123 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
125 return 1 if refaddr($self) == refaddr($other);
127 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
128 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
131 return unless $self->constraint == $other->constraint;
133 if ( $self->has_parent ) {
134 return unless $other->has_parent;
135 return unless $self->parent->equals( $other->parent );
137 return if $other->has_parent;
144 my ($self, $type_or_name) = @_;
146 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
148 ($self->equals($type) || $self->is_subtype_of($type));
152 my ($self, $type_or_name) = @_;
154 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
158 while (my $parent = $current->parent) {
159 return 1 if $parent->equals($type);
166 ## compiling the type constraint
168 sub compile_type_constraint {
170 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
173 ## type compilers ...
175 sub _actually_compile_type_constraint {
178 return $self->_compile_hand_optimized_type_constraint
179 if $self->has_hand_optimized_type_constraint;
181 my $check = $self->constraint;
182 unless ( defined $check ) {
184 Moose->throw_error( "Could not compile type constraint '"
186 . "' because no constraint check" );
189 return $self->_compile_subtype($check)
190 if $self->has_parent;
192 return $self->_compile_type($check);
195 sub _compile_hand_optimized_type_constraint {
198 my $type_constraint = $self->hand_optimized_type_constraint;
200 unless ( ref $type_constraint ) {
202 Carp::confess ("Hand optimized type constraint for " . $self->name . " is not a code reference");
203 Moose->throw_error("Hand optimized type constraint is not a code reference");
206 return $type_constraint;
209 sub _compile_subtype {
210 my ($self, $check) = @_;
212 # gather all the parent constraintss in order
214 my $optimized_parent;
215 foreach my $parent ($self->_collect_all_parents) {
216 # if a parent is optimized, the optimized constraint already includes
217 # all of its parents tcs, so we can break the loop
218 if ($parent->has_hand_optimized_type_constraint) {
219 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
223 push @parents => $parent->constraint;
227 @parents = grep { $_ != $null_constraint } reverse @parents;
229 unless ( @parents ) {
230 return $self->_compile_type($check);
231 } elsif( $optimized_parent and @parents == 1 ) {
232 # the case of just one optimized parent is optimized to prevent
233 # looping and the unnecessary localization
234 if ( $check == $null_constraint ) {
235 return $optimized_parent;
237 return Class::MOP::subname($self->name, sub {
238 return undef unless $optimized_parent->($_[0]);
245 # general case, check all the constraints, from the first parent to ourselves
246 my @checks = @parents;
247 push @checks, $check if $check != $null_constraint;
248 return Class::MOP::subname($self->name => sub {
251 foreach my $check (@checks) {
252 return undef unless $check->(@args);
260 my ($self, $check) = @_;
262 return $check if $check == $null_constraint; # Item, Any
264 return Class::MOP::subname($self->name => sub {
273 sub _collect_all_parents {
276 my $current = $self->parent;
277 while (defined $current) {
278 push @parents => $current;
279 $current = $current->parent;
284 sub create_child_type {
285 my ($self, %opts) = @_;
286 my $class = ref $self;
287 return $class->new(%opts, parent => $self);
298 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
302 This class represents a single type constraint. Moose's built-in type
303 constraints, as well as constraints you define, are all store in a
304 L<Moose::Meta::TypeConstraint::Registry> object as objects of this
309 C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
315 =item B<< Moose::Meta::TypeConstraint->new(%options) >>
317 This creates a new type constraint based on the provided C<%options>:
323 The constraint name. If a name is not provided, it will be set to
328 A C<Moose::Meta::TypeConstraint> object which is the parent type for
329 the type being created. This is optional.
333 This is the subroutine reference that implements the actual constraint
334 check. This defaults to a subroutine which always returns true.
338 A subroutine reference which is used to generate an error message when
339 the constraint fails. This is optional.
343 A L<Moose::Meta::TypeCoercion> object representing the coercions to
344 the type. This is optional.
348 This is a variant of the C<constraint> parameter that is somehow
349 optimized. Typically, this means incorporating both the type's
350 constraint and all of its parents' constraints into a single
351 subroutine reference.
355 =item B<< $constraint->equals($type_name_or_object) >>
357 Returns true if the supplied name or type object is the same as the
360 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
362 Returns true if the supplied name or type object is a parent of the
365 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
367 Returns true if the given type is the same as the current type, or is
368 a parent of the current type. This is a shortcut for checking
369 C<equals> and C<is_subtype_of>.
371 =item B<< $constraint->coerce($value) >>
373 This will attempt to coerce the value to the type. If the type does
374 have any defined coercions this will throw an error.
376 =item B<< $constraint->check($value) >>
378 Returns true if the given value passes the constraint for the type.
380 =item B<< $constraint->validate($value) >>
382 This is similar to C<check>. However, if the type I<is valid> then the
383 method returns an explicit C<undef>. If the type is not valid, we call
384 C<< $self->get_message($value) >> internally to generate an error
387 =item B<< $constraint->name >>
389 Returns the type's name, as provided to the constructor.
391 =item B<< $constraint->parent >>
393 Returns the type's parent, as provided to the constructor, if any.
395 =item B<< $constraint->has_parent >>
397 Returns true if the type has a parent type.
399 =item B<< $constraint->parents >>
401 A synonym for C<parent>. This is useful for polymorphism with types
402 that can have more than one parent.
404 =item B<< $constraint->constraint >>
406 Returns the type's constraint, as provided to the constructor.
408 =item B<< $constraint->get_message($value) >>
410 This generates a method for the given value. If the type does not have
411 an explicit message, we generate a default message.
413 =item B<< $constraint->has_message >>
415 Returns true if the type has a message.
417 =item B<< $constraint->message >>
419 Returns the type's message as a subroutine reference.
421 =item B<< $constraint->coercion >>
423 Returns the type's L<Moose::Meta::TypeCoercion> object, if one
426 =item B<< $constraint->has_coercion >>
428 Returns true if the type has a coercion.
430 =item B<< $constraint->hand_optimized_type_constraint >>
432 Returns the type's hand optimized constraint, as provided to the
433 constructor via the C<optimized> option.
435 =item B<< $constraint->has_hand_optimized_type_constraint >>
437 Returns true if the type has an optimized constraint.
439 =item B<< $constraint->create_child_type(%options) >>
441 This returns a new type constraint of the same class using the
442 provided C<%options>. The C<parent> option will be the current type.
444 This method exists so that subclasses of this class can override this
445 behavior and change how child types are created.
451 All complex software has bugs lurking in it, and this module is no
452 exception. If you find a bug please either email me, or add the bug
457 Stevan Little E<lt>stevan@iinteractive.comE<gt>
459 =head1 COPYRIGHT AND LICENSE
461 Copyright 2006-2009 by Infinity Interactive, Inc.
463 L<http://www.iinteractive.com>
465 This library is free software; you can redistribute it and/or modify
466 it under the same terms as Perl itself.