2 package Moose::Meta::TypeConstraint;
8 use Sub::Name 'subname';
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.07';
14 use Moose::Meta::TypeConstraint::Union;
16 __PACKAGE__->meta->add_attribute('name' => (reader => 'name' ));
17 __PACKAGE__->meta->add_attribute('parent' => (reader => 'parent' ));
18 __PACKAGE__->meta->add_attribute('constraint' => (reader => 'constraint'));
19 __PACKAGE__->meta->add_attribute('message' => (
20 accessor => 'message',
21 predicate => 'has_message'
23 __PACKAGE__->meta->add_attribute('coercion' => (
24 accessor => 'coercion',
25 predicate => 'has_coercion'
29 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
30 accessor => '_compiled_type_constraint'
33 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
34 init_arg => 'optimized',
35 accessor => 'hand_optimized_type_constraint',
36 predicate => 'has_hand_optimized_type_constraint',
41 my $self = $class->meta->new_object(@_);
42 $self->compile_type_constraint();
47 ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_)
50 sub _collect_all_parents {
53 my $current = $self->parent;
54 while (defined $current) {
55 push @parents => $current;
56 $current = $current->parent;
61 sub compile_type_constraint {
64 if ($self->has_hand_optimized_type_constraint) {
65 my $type_constraint = $self->hand_optimized_type_constraint;
66 $self->_compiled_type_constraint(sub {
67 return undef unless $type_constraint->($_[0]);
73 my $check = $self->constraint;
75 || confess "Could not compile type constraint '" . $self->name . "' because no constraint check";
76 my $parent = $self->parent;
77 if (defined $parent) {
78 # we have a subtype ...
79 # so we gather all the parents in order
80 # and grab their constraints ...
82 foreach my $parent ($self->_collect_all_parents) {
83 if ($parent->has_hand_optimized_type_constraint) {
84 unshift @parents => $parent->hand_optimized_type_constraint;
88 unshift @parents => $parent->constraint;
92 # then we compile them to run without
93 # having to recurse as we did before
94 $self->_compiled_type_constraint(subname $self->name => sub {
96 foreach my $parent (@parents) {
97 return undef unless $parent->($_[0]);
99 return undef unless $check->($_[0]);
104 # we have a type ....
105 $self->_compiled_type_constraint(subname $self->name => sub {
107 return undef unless $check->($_[0]);
113 sub check { $_[0]->_compiled_type_constraint->($_[1]) }
116 my ($self, $value) = @_;
117 if ($self->_compiled_type_constraint->($value)) {
121 if ($self->has_message) {
123 return $self->message->($value);
126 return "Validation failed for '" . $self->name . "' failed";
132 my ($self, $type_name) = @_;
133 ($self->name eq $type_name || $self->is_subtype_of($type_name));
137 my ($self, $type_name) = @_;
139 while (my $parent = $current->parent) {
140 return 1 if $parent->name eq $type_name;
147 my ($class, @type_constraints) = @_;
148 (scalar @type_constraints >= 2)
149 || confess "You must pass in at least 2 Moose::Meta::TypeConstraint instances to make a union";
150 (blessed($_) && $_->isa('Moose::Meta::TypeConstraint'))
151 || confess "You must pass in only Moose::Meta::TypeConstraint instances to make unions"
152 foreach @type_constraints;
153 return Moose::Meta::TypeConstraint::Union->new(
154 type_constraints => \@type_constraints,
166 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
170 For the most part, the only time you will ever encounter an
171 instance of this class is if you are doing some serious deep
172 introspection. This API should not be considered final, but
173 it is B<highly unlikely> that this will matter to a regular
176 If you wish to use features at this depth, please come to the
177 #moose IRC channel on irc.perl.org and we can talk :)
187 =item B<is_a_type_of ($type_name)>
189 This checks the current type name, and if it does not match,
190 checks if it is a subtype of it.
192 =item B<is_subtype_of ($type_name)>
194 =item B<compile_type_constraint>
196 =item B<coerce ($value)>
198 This will apply the type-coercion if applicable.
200 =item B<check ($value)>
202 This method will return a true (C<1>) if the C<$value> passes the
203 constraint, and false (C<0>) otherwise.
205 =item B<validate ($value)>
207 This method is similar to C<check>, but it deals with the error
208 message. If the C<$value> passes the constraint, C<undef> will be
209 returned. If the C<$value> does B<not> pass the constraint, then
210 the C<message> will be used to construct a custom error message.
222 =item B<has_coercion>
226 =item B<hand_optimized_type_constraint>
228 =item B<has_hand_optimized_type_constraint>
234 =item B<union (@type_constraints)>
240 All complex software has bugs lurking in it, and this module is no
241 exception. If you find a bug please either email me, or add the bug
246 Stevan Little E<lt>stevan@iinteractive.comE<gt>
248 =head1 COPYRIGHT AND LICENSE
250 Copyright 2006 by Infinity Interactive, Inc.
252 L<http://www.iinteractive.com>
254 This library is free software; you can redistribute it and/or modify
255 it under the same terms as Perl itself.