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.73_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 $coercion->coerce(@_);
89 my ($self, @args) = @_;
90 my $constraint_subref = $self->_compiled_type_constraint;
91 return $constraint_subref->(@args) ? 1 : undef;
95 my ($self, $value) = @_;
96 if ($self->_compiled_type_constraint->($value)) {
100 $self->get_message($value);
105 my ($self, $value) = @_;
106 if (my $msg = $self->message) {
108 return $msg->($value);
111 $value = (defined $value ? overload::StrVal($value) : 'undef');
112 return "Validation failed for '" . $self->name . "' failed with value $value";
116 ## type predicates ...
119 my ( $self, $type_or_name ) = @_;
121 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
123 return 1 if refaddr($self) == refaddr($other);
125 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
126 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
129 return unless $self->constraint == $other->constraint;
131 if ( $self->has_parent ) {
132 return unless $other->has_parent;
133 return unless $self->parent->equals( $other->parent );
135 return if $other->has_parent;
142 my ($self, $type_or_name) = @_;
144 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
146 ($self->equals($type) || $self->is_subtype_of($type));
150 my ($self, $type_or_name) = @_;
152 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
156 while (my $parent = $current->parent) {
157 return 1 if $parent->equals($type);
164 ## compiling the type constraint
166 sub compile_type_constraint {
168 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
171 ## type compilers ...
173 sub _actually_compile_type_constraint {
176 return $self->_compile_hand_optimized_type_constraint
177 if $self->has_hand_optimized_type_constraint;
179 my $check = $self->constraint;
180 unless ( defined $check ) {
182 Moose->throw_error( "Could not compile type constraint '"
184 . "' because no constraint check" );
187 return $self->_compile_subtype($check)
188 if $self->has_parent;
190 return $self->_compile_type($check);
193 sub _compile_hand_optimized_type_constraint {
196 my $type_constraint = $self->hand_optimized_type_constraint;
198 unless ( ref $type_constraint ) {
200 Carp::confess ("Hand optimized type constraint for " . $self->name . " is not a code reference");
201 Moose->throw_error("Hand optimized type constraint is not a code reference");
204 return $type_constraint;
207 sub _compile_subtype {
208 my ($self, $check) = @_;
210 # gather all the parent constraintss in order
212 my $optimized_parent;
213 foreach my $parent ($self->_collect_all_parents) {
214 # if a parent is optimized, the optimized constraint already includes
215 # all of its parents tcs, so we can break the loop
216 if ($parent->has_hand_optimized_type_constraint) {
217 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
221 push @parents => $parent->constraint;
225 @parents = grep { $_ != $null_constraint } reverse @parents;
227 unless ( @parents ) {
228 return $self->_compile_type($check);
229 } elsif( $optimized_parent and @parents == 1 ) {
230 # the case of just one optimized parent is optimized to prevent
231 # looping and the unnecessary localization
232 if ( $check == $null_constraint ) {
233 return $optimized_parent;
235 return Class::MOP::subname($self->name, sub {
236 return undef unless $optimized_parent->($_[0]);
243 # general case, check all the constraints, from the first parent to ourselves
244 my @checks = @parents;
245 push @checks, $check if $check != $null_constraint;
246 return Class::MOP::subname($self->name => sub {
249 foreach my $check (@checks) {
250 return undef unless $check->(@args);
258 my ($self, $check) = @_;
260 return $check if $check == $null_constraint; # Item, Any
262 return Class::MOP::subname($self->name => sub {
271 sub _collect_all_parents {
274 my $current = $self->parent;
275 while (defined $current) {
276 push @parents => $current;
277 $current = $current->parent;
282 sub create_child_type {
283 my ($self, %opts) = @_;
284 my $class = ref $self;
285 return $class->new(%opts, parent => $self);
288 ## this should get deprecated actually ...
290 sub union { Carp::croak "DEPRECATED" }
300 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
304 This class represents a single type constraint. Moose's built-in type
305 constraints, as well as constraints you define, are all store in a
306 L<Moose::Meta::TypeConstraint::Registry> object as objects of this
311 C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
317 =item B<< Moose::Meta::TypeConstraint->new(%options) >>
319 This creates a new type constraint based on the provided C<%options>:
325 The constraint name. If a name is not provided, it will be set to
330 A C<Moose::Meta::TypeConstraint> object which is the parent type for
331 the type being created. This is optional.
335 This is the subroutine reference that implements the actual constraint
336 check. This defaults to a subroutine which always returns true.
340 A subroutine reference which is used to generate an error message when
341 the constraint fails. This is optional.
345 A L<Moose::Meta::TypeCoercion> object representing the coercions to
346 the type. This is optional.
350 This is a variant of the C<constraint> parameter that is somehow
351 optimized. Typically, this means incorporating both the type's
352 constraint and all of its parents' constraints into a single
353 subroutine reference.
357 =item B<< $constraint->equals($type_name_or_object) >>
359 Returns true if the supplied name or type object is the same as the
362 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
364 Returns true if the supplied name or type object is a parent of the
367 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
369 Returns true if the given type is the same as the current type, or is
370 a parent of the current type. This is a shortcut for checking
371 C<equals> and C<is_subtype_of>.
373 =item B<< $constraint->coerce($value) >>
375 This will attempt to coerce the value to the type. If the type does
376 have any defined coercions this will throw an error.
378 =item B<< $constraint->check($value) >>
380 Returns true if the given value passes the constraint for the type.
382 =item B<< $constraint->validate($value) >>
384 This is similar to C<check>. However, if the type I<is valid> then the
385 method returns an explicit C<undef>. If the type is not valid, we call
386 C<< $self->get_message($value) >> internally to generate an error
389 =item B<< $constraint->name >>
391 Returns the type's name, as provided to the constructor.
393 =item B<< $constraint->parent >>
395 Returns the type's parent, as provided to the constructor, if any.
397 =item B<< $constraint->has_parent >>
399 Returns true if the type has a parent type.
401 =item B<< $constraint->parents >>
403 A synonym for C<parent>. This is useful for polymorphism with types
404 that can have more than one parent.
406 =item B<< $constraint->constraint >>
408 Returns the type's constraint, as provided to the constructor.
410 =item B<< $constraint->get_message($value) >>
412 This generates a method for the given value. If the type does not have
413 an explicit message, we generate a default message.
415 =item B<< $constraint->has_message >>
417 Returns true if the type has a message.
419 =item B<< $constraint->message >>
421 Returns the type's message as a subroutine reference.
423 =item B<< $constraint->coercion >>
425 Returns the type's L<Moose::Meta::TypeCoercion> object, if one
428 =item B<< $constraint->has_coercion >>
430 Returns true if the type has a coercion.
432 =item B<< $constraint->hand_optimized_type_constraint >>
434 Returns the type's hand optimized constraint, as provided to the
435 constructor via the C<optimized> option.
437 =item B<< $constraint->has_hand_optimized_type_constraint >>
439 Returns true if the type has an optimized constraint.
441 =item B<< $constraint->create_child_type(%options) >>
443 This returns a new type constraint of the same class using the
444 provided C<%options>. The C<parent> option will be the current type.
446 This method exists so that subclasses of this class can override this
447 behavior and change how child types are created.
453 All complex software has bugs lurking in it, and this module is no
454 exception. If you find a bug please either email me, or add the bug
459 Stevan Little E<lt>stevan@iinteractive.comE<gt>
461 =head1 COPYRIGHT AND LICENSE
463 Copyright 2006-2009 by Infinity Interactive, Inc.
465 L<http://www.iinteractive.com>
467 This library is free software; you can redistribute it and/or modify
468 it under the same terms as Perl itself.