2 package Moose::Meta::TypeConstraint;
8 use Sub::Name 'subname';
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.08';
13 our $AUTHORITY = 'cpan:STEVAN';
15 use Moose::Meta::TypeConstraint::Union;
17 __PACKAGE__->meta->add_attribute('name' => (reader => 'name' ));
18 __PACKAGE__->meta->add_attribute('parent' => (reader => 'parent' ));
19 __PACKAGE__->meta->add_attribute('constraint' => (reader => 'constraint'));
20 __PACKAGE__->meta->add_attribute('message' => (
21 accessor => 'message',
22 predicate => 'has_message'
24 __PACKAGE__->meta->add_attribute('coercion' => (
25 accessor => 'coercion',
26 predicate => 'has_coercion'
30 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
31 accessor => '_compiled_type_constraint'
34 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
35 init_arg => 'optimized',
36 accessor => 'hand_optimized_type_constraint',
37 predicate => 'has_hand_optimized_type_constraint',
42 my $self = $class->meta->new_object(@_);
43 $self->compile_type_constraint();
48 ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_)
51 sub _collect_all_parents {
54 my $current = $self->parent;
55 while (defined $current) {
56 push @parents => $current;
57 $current = $current->parent;
62 sub compile_type_constraint {
65 if ($self->has_hand_optimized_type_constraint) {
66 my $type_constraint = $self->hand_optimized_type_constraint;
67 $self->_compiled_type_constraint(sub {
68 return undef unless $type_constraint->($_[0]);
74 my $check = $self->constraint;
76 || confess "Could not compile type constraint '" . $self->name . "' because no constraint check";
77 my $parent = $self->parent;
78 if (defined $parent) {
79 # we have a subtype ...
80 # so we gather all the parents in order
81 # and grab their constraints ...
83 foreach my $parent ($self->_collect_all_parents) {
84 if ($parent->has_hand_optimized_type_constraint) {
85 unshift @parents => $parent->hand_optimized_type_constraint;
89 unshift @parents => $parent->constraint;
93 # then we compile them to run without
94 # having to recurse as we did before
95 $self->_compiled_type_constraint(subname $self->name => sub {
97 foreach my $parent (@parents) {
98 return undef unless $parent->($_[0]);
100 return undef unless $check->($_[0]);
105 # we have a type ....
106 $self->_compiled_type_constraint(subname $self->name => sub {
108 return undef unless $check->($_[0]);
114 sub check { $_[0]->_compiled_type_constraint->($_[1]) }
117 my ($self, $value) = @_;
118 if ($self->_compiled_type_constraint->($value)) {
122 if ($self->has_message) {
124 return $self->message->($value);
127 return "Validation failed for '" . $self->name . "' failed";
133 my ($self, $type_name) = @_;
134 ($self->name eq $type_name || $self->is_subtype_of($type_name));
138 my ($self, $type_name) = @_;
140 while (my $parent = $current->parent) {
141 return 1 if $parent->name eq $type_name;
148 my ($class, @type_constraints) = @_;
149 (scalar @type_constraints >= 2)
150 || confess "You must pass in at least 2 Moose::Meta::TypeConstraint instances to make a union";
151 (blessed($_) && $_->isa('Moose::Meta::TypeConstraint'))
152 || confess "You must pass in only Moose::Meta::TypeConstraint instances to make unions"
153 foreach @type_constraints;
154 return Moose::Meta::TypeConstraint::Union->new(
155 type_constraints => \@type_constraints,
167 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
171 For the most part, the only time you will ever encounter an
172 instance of this class is if you are doing some serious deep
173 introspection. This API should not be considered final, but
174 it is B<highly unlikely> that this will matter to a regular
177 If you wish to use features at this depth, please come to the
178 #moose IRC channel on irc.perl.org and we can talk :)
188 =item B<is_a_type_of ($type_name)>
190 This checks the current type name, and if it does not match,
191 checks if it is a subtype of it.
193 =item B<is_subtype_of ($type_name)>
195 =item B<compile_type_constraint>
197 =item B<coerce ($value)>
199 This will apply the type-coercion if applicable.
201 =item B<check ($value)>
203 This method will return a true (C<1>) if the C<$value> passes the
204 constraint, and false (C<0>) otherwise.
206 =item B<validate ($value)>
208 This method is similar to C<check>, but it deals with the error
209 message. If the C<$value> passes the constraint, C<undef> will be
210 returned. If the C<$value> does B<not> pass the constraint, then
211 the C<message> will be used to construct a custom error message.
223 =item B<has_coercion>
227 =item B<hand_optimized_type_constraint>
229 =item B<has_hand_optimized_type_constraint>
235 =item B<union (@type_constraints)>
241 All complex software has bugs lurking in it, and this module is no
242 exception. If you find a bug please either email me, or add the bug
247 Stevan Little E<lt>stevan@iinteractive.comE<gt>
249 =head1 COPYRIGHT AND LICENSE
251 Copyright 2006, 2007 by Infinity Interactive, Inc.
253 L<http://www.iinteractive.com>
255 This library is free software; you can redistribute it and/or modify
256 it under the same terms as Perl itself.