2 package Moose::Meta::TypeConstraint;
8 use overload '""' => sub { shift->name }, # stringify to tc name
11 use Scalar::Util qw(blessed refaddr);
12 use Sub::Name qw(subname);
14 use base qw(Class::MOP::Object);
16 our $VERSION = '0.81';
17 $VERSION = eval $VERSION;
18 our $AUTHORITY = 'cpan:STEVAN';
20 __PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
21 __PACKAGE__->meta->add_attribute('parent' => (
23 predicate => 'has_parent',
26 my $null_constraint = sub { 1 };
27 __PACKAGE__->meta->add_attribute('constraint' => (
28 reader => 'constraint',
29 writer => '_set_constraint',
30 default => sub { $null_constraint }
32 __PACKAGE__->meta->add_attribute('message' => (
33 accessor => 'message',
34 predicate => 'has_message'
36 __PACKAGE__->meta->add_attribute('coercion' => (
37 accessor => 'coercion',
38 predicate => 'has_coercion'
41 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
42 init_arg => 'optimized',
43 accessor => 'hand_optimized_type_constraint',
44 predicate => 'has_hand_optimized_type_constraint',
54 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
55 accessor => '_compiled_type_constraint',
56 predicate => '_has_compiled_type_constraint'
58 __PACKAGE__->meta->add_attribute('package_defined_in' => (
59 accessor => '_package_defined_in'
64 my ($first, @rest) = @_;
65 my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
66 $args{name} = $args{name} ? "$args{name}" : "__ANON__";
68 my $self = $class->_new(%args);
69 $self->compile_type_constraint()
70 unless $self->_has_compiled_type_constraint;
79 my $coercion = $self->coercion;
83 Moose->throw_error("Cannot coerce without a type coercion");
86 return $_[0] if $self->check($_[0]);
88 return $coercion->coerce(@_);
92 my ($self, @args) = @_;
93 my $constraint_subref = $self->_compiled_type_constraint;
94 return $constraint_subref->(@args) ? 1 : undef;
98 my ($self, $value) = @_;
99 if ($self->_compiled_type_constraint->($value)) {
103 $self->get_message($value);
108 my ($self, $value) = @_;
109 if (my $msg = $self->message) {
111 return $msg->($value);
114 $value = (defined $value ? overload::StrVal($value) : 'undef');
115 return "Validation failed for '" . $self->name . "' failed with value $value";
119 ## type predicates ...
122 my ( $self, $type_or_name ) = @_;
124 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
126 return 1 if refaddr($self) == refaddr($other);
128 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
129 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
132 return unless $self->constraint == $other->constraint;
134 if ( $self->has_parent ) {
135 return unless $other->has_parent;
136 return unless $self->parent->equals( $other->parent );
138 return if $other->has_parent;
145 my ($self, $type_or_name) = @_;
147 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
149 ($self->equals($type) || $self->is_subtype_of($type));
153 my ($self, $type_or_name) = @_;
155 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
159 while (my $parent = $current->parent) {
160 return 1 if $parent->equals($type);
167 ## compiling the type constraint
169 sub compile_type_constraint {
171 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
174 ## type compilers ...
176 sub _actually_compile_type_constraint {
179 return $self->_compile_hand_optimized_type_constraint
180 if $self->has_hand_optimized_type_constraint;
182 my $check = $self->constraint;
183 unless ( defined $check ) {
185 Moose->throw_error( "Could not compile type constraint '"
187 . "' because no constraint check" );
190 return $self->_compile_subtype($check)
191 if $self->has_parent;
193 return $self->_compile_type($check);
196 sub _compile_hand_optimized_type_constraint {
199 my $type_constraint = $self->hand_optimized_type_constraint;
201 unless ( ref $type_constraint ) {
203 Carp::confess ("Hand optimized type constraint for " . $self->name . " is not a code reference");
204 Moose->throw_error("Hand optimized type constraint is not a code reference");
207 return $type_constraint;
210 sub _compile_subtype {
211 my ($self, $check) = @_;
213 # gather all the parent constraintss in order
215 my $optimized_parent;
216 foreach my $parent ($self->_collect_all_parents) {
217 # if a parent is optimized, the optimized constraint already includes
218 # all of its parents tcs, so we can break the loop
219 if ($parent->has_hand_optimized_type_constraint) {
220 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
224 push @parents => $parent->constraint;
228 @parents = grep { $_ != $null_constraint } reverse @parents;
230 unless ( @parents ) {
231 return $self->_compile_type($check);
232 } elsif( $optimized_parent and @parents == 1 ) {
233 # the case of just one optimized parent is optimized to prevent
234 # looping and the unnecessary localization
235 if ( $check == $null_constraint ) {
236 return $optimized_parent;
238 return subname($self->name, sub {
239 return undef unless $optimized_parent->($_[0]);
246 # general case, check all the constraints, from the first parent to ourselves
247 my @checks = @parents;
248 push @checks, $check if $check != $null_constraint;
249 return subname($self->name => sub {
252 foreach my $check (@checks) {
253 return undef unless $check->(@args);
261 my ($self, $check) = @_;
263 return $check if $check == $null_constraint; # Item, Any
265 return subname($self->name => sub {
274 sub _collect_all_parents {
277 my $current = $self->parent;
278 while (defined $current) {
279 push @parents => $current;
280 $current = $current->parent;
285 sub create_child_type {
286 my ($self, %opts) = @_;
287 my $class = ref $self;
288 return $class->new(%opts, parent => $self);
299 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
303 This class represents a single type constraint. Moose's built-in type
304 constraints, as well as constraints you define, are all store in a
305 L<Moose::Meta::TypeConstraint::Registry> object as objects of this
310 C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
316 =item B<< Moose::Meta::TypeConstraint->new(%options) >>
318 This creates a new type constraint based on the provided C<%options>:
324 The constraint name. If a name is not provided, it will be set to
329 A C<Moose::Meta::TypeConstraint> object which is the parent type for
330 the type being created. This is optional.
334 This is the subroutine reference that implements the actual constraint
335 check. This defaults to a subroutine which always returns true.
339 A subroutine reference which is used to generate an error message when
340 the constraint fails. This is optional.
344 A L<Moose::Meta::TypeCoercion> object representing the coercions to
345 the type. This is optional.
349 This is a variant of the C<constraint> parameter that is somehow
350 optimized. Typically, this means incorporating both the type's
351 constraint and all of its parents' constraints into a single
352 subroutine reference.
356 =item B<< $constraint->equals($type_name_or_object) >>
358 Returns true if the supplied name or type object is the same as the
361 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
363 Returns true if the supplied name or type object is a parent of the
366 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
368 Returns true if the given type is the same as the current type, or is
369 a parent of the current type. This is a shortcut for checking
370 C<equals> and C<is_subtype_of>.
372 =item B<< $constraint->coerce($value) >>
374 This will attempt to coerce the value to the type. If the type does
375 have any defined coercions this will throw an error.
377 =item B<< $constraint->check($value) >>
379 Returns true if the given value passes the constraint for the type.
381 =item B<< $constraint->validate($value) >>
383 This is similar to C<check>. However, if the type I<is valid> then the
384 method returns an explicit C<undef>. If the type is not valid, we call
385 C<< $self->get_message($value) >> internally to generate an error
388 =item B<< $constraint->name >>
390 Returns the type's name, as provided to the constructor.
392 =item B<< $constraint->parent >>
394 Returns the type's parent, as provided to the constructor, if any.
396 =item B<< $constraint->has_parent >>
398 Returns true if the type has a parent type.
400 =item B<< $constraint->parents >>
402 A synonym for C<parent>. This is useful for polymorphism with types
403 that can have more than one parent.
405 =item B<< $constraint->constraint >>
407 Returns the type's constraint, as provided to the constructor.
409 =item B<< $constraint->get_message($value) >>
411 This generates a method for the given value. If the type does not have
412 an explicit message, we generate a default message.
414 =item B<< $constraint->has_message >>
416 Returns true if the type has a message.
418 =item B<< $constraint->message >>
420 Returns the type's message as a subroutine reference.
422 =item B<< $constraint->coercion >>
424 Returns the type's L<Moose::Meta::TypeCoercion> object, if one
427 =item B<< $constraint->has_coercion >>
429 Returns true if the type has a coercion.
431 =item B<< $constraint->hand_optimized_type_constraint >>
433 Returns the type's hand optimized constraint, as provided to the
434 constructor via the C<optimized> option.
436 =item B<< $constraint->has_hand_optimized_type_constraint >>
438 Returns true if the type has an optimized constraint.
440 =item B<< $constraint->create_child_type(%options) >>
442 This returns a new type constraint of the same class using the
443 provided C<%options>. The C<parent> option will be the current type.
445 This method exists so that subclasses of this class can override this
446 behavior and change how child types are created.
452 All complex software has bugs lurking in it, and this module is no
453 exception. If you find a bug please either email me, or add the bug
458 Stevan Little E<lt>stevan@iinteractive.comE<gt>
460 =head1 COPYRIGHT AND LICENSE
462 Copyright 2006-2009 by Infinity Interactive, Inc.
464 L<http://www.iinteractive.com>
466 This library is free software; you can redistribute it and/or modify
467 it under the same terms as Perl itself.