2 package Moose::Meta::TypeConstraint;
8 use overload '0+' => sub { refaddr(shift) }, # id an object
9 '""' => sub { shift->name }, # stringify to tc name
13 use Scalar::Util qw(blessed refaddr);
14 use Sub::Name qw(subname);
16 use base qw(Class::MOP::Object);
18 our $VERSION = '1.23';
19 $VERSION = eval $VERSION;
20 our $AUTHORITY = 'cpan:STEVAN';
22 __PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
23 __PACKAGE__->meta->add_attribute('parent' => (
25 predicate => 'has_parent',
28 my $null_constraint = sub { 1 };
29 __PACKAGE__->meta->add_attribute('constraint' => (
30 reader => 'constraint',
31 writer => '_set_constraint',
32 default => sub { $null_constraint }
34 __PACKAGE__->meta->add_attribute('message' => (
35 accessor => 'message',
36 predicate => 'has_message'
38 __PACKAGE__->meta->add_attribute('coercion' => (
39 accessor => 'coercion',
40 predicate => 'has_coercion'
43 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
44 init_arg => 'optimized',
45 accessor => 'hand_optimized_type_constraint',
46 predicate => 'has_hand_optimized_type_constraint',
56 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
57 accessor => '_compiled_type_constraint',
58 predicate => '_has_compiled_type_constraint'
60 __PACKAGE__->meta->add_attribute('package_defined_in' => (
61 accessor => '_package_defined_in'
66 my ($first, @rest) = @_;
67 my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
68 $args{name} = $args{name} ? "$args{name}" : "__ANON__";
70 my $self = $class->_new(%args);
71 $self->compile_type_constraint()
72 unless $self->_has_compiled_type_constraint;
81 my $coercion = $self->coercion;
85 Moose->throw_error("Cannot coerce without a type coercion");
88 return $_[0] if $self->check($_[0]);
90 return $coercion->coerce(@_);
96 my $coercion = $self->coercion;
100 Moose->throw_error("Cannot coerce without a type coercion");
103 return $_[0] if $self->check($_[0]);
105 my $result = $coercion->coerce(@_);
107 $self->assert_valid($result);
113 my ($self, @args) = @_;
114 my $constraint_subref = $self->_compiled_type_constraint;
115 return $constraint_subref->(@args) ? 1 : undef;
119 my ($self, $value) = @_;
120 if ($self->_compiled_type_constraint->($value)) {
124 $self->get_message($value);
129 my ($self, $value) = @_;
131 my $error = $self->validate($value);
132 return 1 if ! defined $error;
135 Moose->throw_error($error);
139 my ($self, $value) = @_;
140 if (my $msg = $self->message) {
142 return $msg->($value);
145 $value = (defined $value ? overload::StrVal($value) : 'undef');
146 return "Validation failed for '" . $self->name . "' with value $value";
150 ## type predicates ...
153 my ( $self, $type_or_name ) = @_;
155 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
157 return 1 if $self == $other;
159 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
160 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
163 return unless $self->constraint == $other->constraint;
165 if ( $self->has_parent ) {
166 return unless $other->has_parent;
167 return unless $self->parent->equals( $other->parent );
169 return if $other->has_parent;
176 my ($self, $type_or_name) = @_;
178 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
180 ($self->equals($type) || $self->is_subtype_of($type));
184 my ($self, $type_or_name) = @_;
186 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
190 while (my $parent = $current->parent) {
191 return 1 if $parent->equals($type);
198 ## compiling the type constraint
200 sub compile_type_constraint {
202 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
205 ## type compilers ...
207 sub _actually_compile_type_constraint {
210 return $self->_compile_hand_optimized_type_constraint
211 if $self->has_hand_optimized_type_constraint;
213 my $check = $self->constraint;
214 unless ( defined $check ) {
216 Moose->throw_error( "Could not compile type constraint '"
218 . "' because no constraint check" );
221 return $self->_compile_subtype($check)
222 if $self->has_parent;
224 return $self->_compile_type($check);
227 sub _compile_hand_optimized_type_constraint {
230 my $type_constraint = $self->hand_optimized_type_constraint;
232 unless ( ref $type_constraint ) {
234 Carp::confess ("Hand optimized type constraint for " . $self->name . " is not a code reference");
235 Moose->throw_error("Hand optimized type constraint is not a code reference");
238 return $type_constraint;
241 sub _compile_subtype {
242 my ($self, $check) = @_;
244 # gather all the parent constraintss in order
246 my $optimized_parent;
247 foreach my $parent ($self->_collect_all_parents) {
248 # if a parent is optimized, the optimized constraint already includes
249 # all of its parents tcs, so we can break the loop
250 if ($parent->has_hand_optimized_type_constraint) {
251 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
255 push @parents => $parent->constraint;
259 @parents = grep { $_ != $null_constraint } reverse @parents;
261 unless ( @parents ) {
262 return $self->_compile_type($check);
263 } elsif( $optimized_parent and @parents == 1 ) {
264 # the case of just one optimized parent is optimized to prevent
265 # looping and the unnecessary localization
266 if ( $check == $null_constraint ) {
267 return $optimized_parent;
269 return subname($self->name, sub {
270 return undef unless $optimized_parent->($_[0]);
277 # general case, check all the constraints, from the first parent to ourselves
278 my @checks = @parents;
279 push @checks, $check if $check != $null_constraint;
280 return subname($self->name => sub {
283 foreach my $check (@checks) {
284 return undef unless $check->(@args);
292 my ($self, $check) = @_;
294 return $check if $check == $null_constraint; # Item, Any
296 return subname($self->name => sub {
305 sub _collect_all_parents {
308 my $current = $self->parent;
309 while (defined $current) {
310 push @parents => $current;
311 $current = $current->parent;
316 sub create_child_type {
317 my ($self, %opts) = @_;
318 my $class = ref $self;
319 return $class->new(%opts, parent => $self);
330 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
334 This class represents a single type constraint. Moose's built-in type
335 constraints, as well as constraints you define, are all stored in a
336 L<Moose::Meta::TypeConstraint::Registry> object as objects of this
341 C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
347 =item B<< Moose::Meta::TypeConstraint->new(%options) >>
349 This creates a new type constraint based on the provided C<%options>:
355 The constraint name. If a name is not provided, it will be set to
360 A C<Moose::Meta::TypeConstraint> object which is the parent type for
361 the type being created. This is optional.
365 This is the subroutine reference that implements the actual constraint
366 check. This defaults to a subroutine which always returns true.
370 A subroutine reference which is used to generate an error message when
371 the constraint fails. This is optional.
375 A L<Moose::Meta::TypeCoercion> object representing the coercions to
376 the type. This is optional.
380 This is a variant of the C<constraint> parameter that is somehow
381 optimized. Typically, this means incorporating both the type's
382 constraint and all of its parents' constraints into a single
383 subroutine reference.
387 =item B<< $constraint->equals($type_name_or_object) >>
389 Returns true if the supplied name or type object is the same as the
392 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
394 Returns true if the supplied name or type object is a parent of the
397 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
399 Returns true if the given type is the same as the current type, or is
400 a parent of the current type. This is a shortcut for checking
401 C<equals> and C<is_subtype_of>.
403 =item B<< $constraint->coerce($value) >>
405 This will attempt to coerce the value to the type. If the type does not
406 have any defined coercions this will throw an error.
408 If no coercion can produce a value matching C<$constraint>, the original
411 =item B<< $constraint->assert_coerce($value) >>
413 This method behaves just like C<coerce>, but if the result is not valid
414 according to C<$constraint>, an error is thrown.
416 =item B<< $constraint->check($value) >>
418 Returns true if the given value passes the constraint for the type.
420 =item B<< $constraint->validate($value) >>
422 This is similar to C<check>. However, if the type I<is valid> then the
423 method returns an explicit C<undef>. If the type is not valid, we call
424 C<< $self->get_message($value) >> internally to generate an error
427 =item B<< $constraint->assert_valid($value) >>
429 Like C<check> and C<validate>, this method checks whether C<$value> is
430 valid under the constraint. If it is, it will return true. If it is not,
431 an exception will be thrown with the results of
432 C<< $self->get_message($value) >>.
434 =item B<< $constraint->name >>
436 Returns the type's name, as provided to the constructor.
438 =item B<< $constraint->parent >>
440 Returns the type's parent, as provided to the constructor, if any.
442 =item B<< $constraint->has_parent >>
444 Returns true if the type has a parent type.
446 =item B<< $constraint->parents >>
448 A synonym for C<parent>. This is useful for polymorphism with types
449 that can have more than one parent.
451 =item B<< $constraint->constraint >>
453 Returns the type's constraint, as provided to the constructor.
455 =item B<< $constraint->get_message($value) >>
457 This generates a method for the given value. If the type does not have
458 an explicit message, we generate a default message.
460 =item B<< $constraint->has_message >>
462 Returns true if the type has a message.
464 =item B<< $constraint->message >>
466 Returns the type's message as a subroutine reference.
468 =item B<< $constraint->coercion >>
470 Returns the type's L<Moose::Meta::TypeCoercion> object, if one
473 =item B<< $constraint->has_coercion >>
475 Returns true if the type has a coercion.
477 =item B<< $constraint->hand_optimized_type_constraint >>
479 Returns the type's hand optimized constraint, as provided to the
480 constructor via the C<optimized> option.
482 =item B<< $constraint->has_hand_optimized_type_constraint >>
484 Returns true if the type has an optimized constraint.
486 =item B<< $constraint->create_child_type(%options) >>
488 This returns a new type constraint of the same class using the
489 provided C<%options>. The C<parent> option will be the current type.
491 This method exists so that subclasses of this class can override this
492 behavior and change how child types are created.
498 See L<Moose/BUGS> for details on reporting bugs.
502 Stevan Little E<lt>stevan@iinteractive.comE<gt>
504 =head1 COPYRIGHT AND LICENSE
506 Copyright 2006-2010 by Infinity Interactive, Inc.
508 L<http://www.iinteractive.com>
510 This library is free software; you can redistribute it and/or modify
511 it under the same terms as Perl itself.