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.08';
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(@_);
94 my ($self, @args) = @_;
95 my $constraint_subref = $self->_compiled_type_constraint;
96 return $constraint_subref->(@args) ? 1 : undef;
100 my ($self, $value) = @_;
101 if ($self->_compiled_type_constraint->($value)) {
105 $self->get_message($value);
110 my ($self, $value) = @_;
112 my $error = $self->validate($value);
113 return 1 if ! defined $error;
116 Moose->throw_error($error);
120 my ($self, $value) = @_;
121 if (my $msg = $self->message) {
123 return $msg->($value);
126 $value = (defined $value ? overload::StrVal($value) : 'undef');
127 return "Validation failed for '" . $self->name . "' with value $value";
131 ## type predicates ...
134 my ( $self, $type_or_name ) = @_;
136 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
138 return 1 if $self == $other;
140 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
141 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
144 return unless $self->constraint == $other->constraint;
146 if ( $self->has_parent ) {
147 return unless $other->has_parent;
148 return unless $self->parent->equals( $other->parent );
150 return if $other->has_parent;
157 my ($self, $type_or_name) = @_;
159 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
161 ($self->equals($type) || $self->is_subtype_of($type));
165 my ($self, $type_or_name) = @_;
167 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
171 while (my $parent = $current->parent) {
172 return 1 if $parent->equals($type);
179 ## compiling the type constraint
181 sub compile_type_constraint {
183 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
186 ## type compilers ...
188 sub _actually_compile_type_constraint {
191 return $self->_compile_hand_optimized_type_constraint
192 if $self->has_hand_optimized_type_constraint;
194 my $check = $self->constraint;
195 unless ( defined $check ) {
197 Moose->throw_error( "Could not compile type constraint '"
199 . "' because no constraint check" );
202 return $self->_compile_subtype($check)
203 if $self->has_parent;
205 return $self->_compile_type($check);
208 sub _compile_hand_optimized_type_constraint {
211 my $type_constraint = $self->hand_optimized_type_constraint;
213 unless ( ref $type_constraint ) {
215 Carp::confess ("Hand optimized type constraint for " . $self->name . " is not a code reference");
216 Moose->throw_error("Hand optimized type constraint is not a code reference");
219 return $type_constraint;
222 sub _compile_subtype {
223 my ($self, $check) = @_;
225 # gather all the parent constraintss in order
227 my $optimized_parent;
228 foreach my $parent ($self->_collect_all_parents) {
229 # if a parent is optimized, the optimized constraint already includes
230 # all of its parents tcs, so we can break the loop
231 if ($parent->has_hand_optimized_type_constraint) {
232 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
236 push @parents => $parent->constraint;
240 @parents = grep { $_ != $null_constraint } reverse @parents;
242 unless ( @parents ) {
243 return $self->_compile_type($check);
244 } elsif( $optimized_parent and @parents == 1 ) {
245 # the case of just one optimized parent is optimized to prevent
246 # looping and the unnecessary localization
247 if ( $check == $null_constraint ) {
248 return $optimized_parent;
250 return subname($self->name, sub {
251 return undef unless $optimized_parent->($_[0]);
258 # general case, check all the constraints, from the first parent to ourselves
259 my @checks = @parents;
260 push @checks, $check if $check != $null_constraint;
261 return subname($self->name => sub {
264 foreach my $check (@checks) {
265 return undef unless $check->(@args);
273 my ($self, $check) = @_;
275 return $check if $check == $null_constraint; # Item, Any
277 return subname($self->name => sub {
286 sub _collect_all_parents {
289 my $current = $self->parent;
290 while (defined $current) {
291 push @parents => $current;
292 $current = $current->parent;
297 sub create_child_type {
298 my ($self, %opts) = @_;
299 my $class = ref $self;
300 return $class->new(%opts, parent => $self);
311 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
315 This class represents a single type constraint. Moose's built-in type
316 constraints, as well as constraints you define, are all stored in a
317 L<Moose::Meta::TypeConstraint::Registry> object as objects of this
322 C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
328 =item B<< Moose::Meta::TypeConstraint->new(%options) >>
330 This creates a new type constraint based on the provided C<%options>:
336 The constraint name. If a name is not provided, it will be set to
341 A C<Moose::Meta::TypeConstraint> object which is the parent type for
342 the type being created. This is optional.
346 This is the subroutine reference that implements the actual constraint
347 check. This defaults to a subroutine which always returns true.
351 A subroutine reference which is used to generate an error message when
352 the constraint fails. This is optional.
356 A L<Moose::Meta::TypeCoercion> object representing the coercions to
357 the type. This is optional.
361 This is a variant of the C<constraint> parameter that is somehow
362 optimized. Typically, this means incorporating both the type's
363 constraint and all of its parents' constraints into a single
364 subroutine reference.
368 =item B<< $constraint->equals($type_name_or_object) >>
370 Returns true if the supplied name or type object is the same as the
373 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
375 Returns true if the supplied name or type object is a parent of the
378 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
380 Returns true if the given type is the same as the current type, or is
381 a parent of the current type. This is a shortcut for checking
382 C<equals> and C<is_subtype_of>.
384 =item B<< $constraint->coerce($value) >>
386 This will attempt to coerce the value to the type. If the type does
387 have any defined coercions this will throw an error.
389 =item B<< $constraint->check($value) >>
391 Returns true if the given value passes the constraint for the type.
393 =item B<< $constraint->validate($value) >>
395 This is similar to C<check>. However, if the type I<is valid> then the
396 method returns an explicit C<undef>. If the type is not valid, we call
397 C<< $self->get_message($value) >> internally to generate an error
400 =item B<< $constraint->assert_valid($value) >>
402 Like C<check> and C<validate>, this method checks whether C<$value> is
403 valid under the constraint. If it is, it will return true. If it is not,
404 an exception will be thrown with the results of
405 C<< $self->get_message($value) >>.
407 =item B<< $constraint->name >>
409 Returns the type's name, as provided to the constructor.
411 =item B<< $constraint->parent >>
413 Returns the type's parent, as provided to the constructor, if any.
415 =item B<< $constraint->has_parent >>
417 Returns true if the type has a parent type.
419 =item B<< $constraint->parents >>
421 A synonym for C<parent>. This is useful for polymorphism with types
422 that can have more than one parent.
424 =item B<< $constraint->constraint >>
426 Returns the type's constraint, as provided to the constructor.
428 =item B<< $constraint->get_message($value) >>
430 This generates a method for the given value. If the type does not have
431 an explicit message, we generate a default message.
433 =item B<< $constraint->has_message >>
435 Returns true if the type has a message.
437 =item B<< $constraint->message >>
439 Returns the type's message as a subroutine reference.
441 =item B<< $constraint->coercion >>
443 Returns the type's L<Moose::Meta::TypeCoercion> object, if one
446 =item B<< $constraint->has_coercion >>
448 Returns true if the type has a coercion.
450 =item B<< $constraint->hand_optimized_type_constraint >>
452 Returns the type's hand optimized constraint, as provided to the
453 constructor via the C<optimized> option.
455 =item B<< $constraint->has_hand_optimized_type_constraint >>
457 Returns true if the type has an optimized constraint.
459 =item B<< $constraint->create_child_type(%options) >>
461 This returns a new type constraint of the same class using the
462 provided C<%options>. The C<parent> option will be the current type.
464 This method exists so that subclasses of this class can override this
465 behavior and change how child types are created.
471 See L<Moose/BUGS> for details on reporting bugs.
475 Stevan Little E<lt>stevan@iinteractive.comE<gt>
477 =head1 COPYRIGHT AND LICENSE
479 Copyright 2006-2010 by Infinity Interactive, Inc.
481 L<http://www.iinteractive.com>
483 This library is free software; you can redistribute it and/or modify
484 it under the same terms as Perl itself.