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.90';
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) = @_;
110 my $error = $self->validate($value);
111 return 1 if ! defined $error;
114 Moose->throw_error($error);
118 my ($self, $value) = @_;
119 if (my $msg = $self->message) {
121 return $msg->($value);
124 $value = (defined $value ? overload::StrVal($value) : 'undef');
125 return "Validation failed for '" . $self->name . "' failed with value $value";
129 ## type predicates ...
132 my ( $self, $type_or_name ) = @_;
134 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
136 return 1 if refaddr($self) == refaddr($other);
138 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
139 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
142 return unless $self->constraint == $other->constraint;
144 if ( $self->has_parent ) {
145 return unless $other->has_parent;
146 return unless $self->parent->equals( $other->parent );
148 return if $other->has_parent;
155 my ($self, $type_or_name) = @_;
157 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
159 ($self->equals($type) || $self->is_subtype_of($type));
163 my ($self, $type_or_name) = @_;
165 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
169 while (my $parent = $current->parent) {
170 return 1 if $parent->equals($type);
177 ## compiling the type constraint
179 sub compile_type_constraint {
181 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
184 ## type compilers ...
186 sub _actually_compile_type_constraint {
189 return $self->_compile_hand_optimized_type_constraint
190 if $self->has_hand_optimized_type_constraint;
192 my $check = $self->constraint;
193 unless ( defined $check ) {
195 Moose->throw_error( "Could not compile type constraint '"
197 . "' because no constraint check" );
200 return $self->_compile_subtype($check)
201 if $self->has_parent;
203 return $self->_compile_type($check);
206 sub _compile_hand_optimized_type_constraint {
209 my $type_constraint = $self->hand_optimized_type_constraint;
211 unless ( ref $type_constraint ) {
213 Carp::confess ("Hand optimized type constraint for " . $self->name . " is not a code reference");
214 Moose->throw_error("Hand optimized type constraint is not a code reference");
217 return $type_constraint;
220 sub _compile_subtype {
221 my ($self, $check) = @_;
223 # gather all the parent constraintss in order
225 my $optimized_parent;
226 foreach my $parent ($self->_collect_all_parents) {
227 # if a parent is optimized, the optimized constraint already includes
228 # all of its parents tcs, so we can break the loop
229 if ($parent->has_hand_optimized_type_constraint) {
230 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
234 push @parents => $parent->constraint;
238 @parents = grep { $_ != $null_constraint } reverse @parents;
240 unless ( @parents ) {
241 return $self->_compile_type($check);
242 } elsif( $optimized_parent and @parents == 1 ) {
243 # the case of just one optimized parent is optimized to prevent
244 # looping and the unnecessary localization
245 if ( $check == $null_constraint ) {
246 return $optimized_parent;
248 return subname($self->name, sub {
249 return undef unless $optimized_parent->($_[0]);
256 # general case, check all the constraints, from the first parent to ourselves
257 my @checks = @parents;
258 push @checks, $check if $check != $null_constraint;
259 return subname($self->name => sub {
262 foreach my $check (@checks) {
263 return undef unless $check->(@args);
271 my ($self, $check) = @_;
273 return $check if $check == $null_constraint; # Item, Any
275 return subname($self->name => sub {
284 sub _collect_all_parents {
287 my $current = $self->parent;
288 while (defined $current) {
289 push @parents => $current;
290 $current = $current->parent;
295 sub create_child_type {
296 my ($self, %opts) = @_;
297 my $class = ref $self;
298 return $class->new(%opts, parent => $self);
309 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
313 This class represents a single type constraint. Moose's built-in type
314 constraints, as well as constraints you define, are all store in a
315 L<Moose::Meta::TypeConstraint::Registry> object as objects of this
320 C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
326 =item B<< Moose::Meta::TypeConstraint->new(%options) >>
328 This creates a new type constraint based on the provided C<%options>:
334 The constraint name. If a name is not provided, it will be set to
339 A C<Moose::Meta::TypeConstraint> object which is the parent type for
340 the type being created. This is optional.
344 This is the subroutine reference that implements the actual constraint
345 check. This defaults to a subroutine which always returns true.
349 A subroutine reference which is used to generate an error message when
350 the constraint fails. This is optional.
354 A L<Moose::Meta::TypeCoercion> object representing the coercions to
355 the type. This is optional.
359 This is a variant of the C<constraint> parameter that is somehow
360 optimized. Typically, this means incorporating both the type's
361 constraint and all of its parents' constraints into a single
362 subroutine reference.
366 =item B<< $constraint->equals($type_name_or_object) >>
368 Returns true if the supplied name or type object is the same as the
371 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
373 Returns true if the supplied name or type object is a parent of the
376 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
378 Returns true if the given type is the same as the current type, or is
379 a parent of the current type. This is a shortcut for checking
380 C<equals> and C<is_subtype_of>.
382 =item B<< $constraint->coerce($value) >>
384 This will attempt to coerce the value to the type. If the type does
385 have any defined coercions this will throw an error.
387 =item B<< $constraint->check($value) >>
389 Returns true if the given value passes the constraint for the type.
391 =item B<< $constraint->validate($value) >>
393 This is similar to C<check>. However, if the type I<is valid> then the
394 method returns an explicit C<undef>. If the type is not valid, we call
395 C<< $self->get_message($value) >> internally to generate an error
398 =item B<< $constraint->assert_valid($value) >>
400 Like C<check> and C<validate>, this method checks whether C<$value> is
401 valid under the constraint. If it is, it will return true. If it is not,
402 an exception will be thrown with the results of
403 C<< $self->get_message($value) >>.
405 =item B<< $constraint->name >>
407 Returns the type's name, as provided to the constructor.
409 =item B<< $constraint->parent >>
411 Returns the type's parent, as provided to the constructor, if any.
413 =item B<< $constraint->has_parent >>
415 Returns true if the type has a parent type.
417 =item B<< $constraint->parents >>
419 A synonym for C<parent>. This is useful for polymorphism with types
420 that can have more than one parent.
422 =item B<< $constraint->constraint >>
424 Returns the type's constraint, as provided to the constructor.
426 =item B<< $constraint->get_message($value) >>
428 This generates a method for the given value. If the type does not have
429 an explicit message, we generate a default message.
431 =item B<< $constraint->has_message >>
433 Returns true if the type has a message.
435 =item B<< $constraint->message >>
437 Returns the type's message as a subroutine reference.
439 =item B<< $constraint->coercion >>
441 Returns the type's L<Moose::Meta::TypeCoercion> object, if one
444 =item B<< $constraint->has_coercion >>
446 Returns true if the type has a coercion.
448 =item B<< $constraint->hand_optimized_type_constraint >>
450 Returns the type's hand optimized constraint, as provided to the
451 constructor via the C<optimized> option.
453 =item B<< $constraint->has_hand_optimized_type_constraint >>
455 Returns true if the type has an optimized constraint.
457 =item B<< $constraint->create_child_type(%options) >>
459 This returns a new type constraint of the same class using the
460 provided C<%options>. The C<parent> option will be the current type.
462 This method exists so that subclasses of this class can override this
463 behavior and change how child types are created.
469 All complex software has bugs lurking in it, and this module is no
470 exception. If you find a bug please either email me, or add the bug
475 Stevan Little E<lt>stevan@iinteractive.comE<gt>
477 =head1 COPYRIGHT AND LICENSE
479 Copyright 2006-2009 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.