2 package Moose::Meta::TypeConstraint;
8 use Sub::Name 'subname';
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.06';
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'
35 my $self = $class->meta->new_object(@_);
36 $self->compile_type_constraint();
41 ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_)
44 sub _collect_all_parents {
47 my $current = $self->parent;
48 while (defined $current) {
49 unshift @parents => $current;
50 $current = $current->parent;
55 sub compile_type_constraint {
57 my $check = $self->constraint;
59 || confess "Could not compile type constraint '" . $self->name . "' because no constraint check";
60 my $parent = $self->parent;
61 if (defined $parent) {
62 # we have a subtype ...
63 # so we gather all the parents in order
64 # and grab their constraints ...
65 my @parents = map { $_->constraint } $self->_collect_all_parents;
66 # then we compile them to run without
67 # having to recurse as we did before
68 $self->_compiled_type_constraint(subname $self->name => sub {
70 foreach my $parent (@parents) {
71 return undef unless $parent->($_[0]);
73 return undef unless $check->($_[0]);
80 $self->_compiled_type_constraint(subname $self->name => sub {
82 return undef unless $check->($_[0]);
88 sub check { $_[0]->_compiled_type_constraint->($_[1]) }
91 my ($self, $value) = @_;
92 if ($self->_compiled_type_constraint->($value)) {
96 if ($self->has_message) {
98 return $self->message->($value);
101 return "Validation failed for '" . $self->name . "' failed";
107 my ($self, $type_name) = @_;
108 ($self->name eq $type_name || $self->is_subtype_of($type_name));
112 my ($self, $type_name) = @_;
114 while (my $parent = $current->parent) {
115 return 1 if $parent->name eq $type_name;
122 my ($class, @type_constraints) = @_;
123 (scalar @type_constraints >= 2)
124 || confess "You must pass in at least 2 Moose::Meta::TypeConstraint instances to make a union";
125 (blessed($_) && $_->isa('Moose::Meta::TypeConstraint'))
126 || confess "You must pass in only Moose::Meta::TypeConstraint instances to make unions"
127 foreach @type_constraints;
128 return Moose::Meta::TypeConstraint::Union->new(
129 type_constraints => \@type_constraints,
141 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
145 For the most part, the only time you will ever encounter an
146 instance of this class is if you are doing some serious deep
147 introspection. This API should not be considered final, but
148 it is B<highly unlikely> that this will matter to a regular
151 If you wish to use features at this depth, please come to the
152 #moose IRC channel on irc.perl.org and we can talk :)
162 =item B<is_a_type_of ($type_name)>
164 This checks the current type name, and if it does not match,
165 checks if it is a subtype of it.
167 =item B<is_subtype_of ($type_name)>
169 =item B<compile_type_constraint>
171 =item B<coerce ($value)>
173 This will apply the type-coercion if applicable.
175 =item B<check ($value)>
177 This method will return a true (C<1>) if the C<$value> passes the
178 constraint, and false (C<0>) otherwise.
180 =item B<validate ($value)>
182 This method is similar to C<check>, but it deals with the error
183 message. If the C<$value> passes the constraint, C<undef> will be
184 returned. If the C<$value> does B<not> pass the constraint, then
185 the C<message> will be used to construct a custom error message.
197 =item B<has_coercion>
205 =item B<union (@type_constraints)>
211 All complex software has bugs lurking in it, and this module is no
212 exception. If you find a bug please either email me, or add the bug
217 Stevan Little E<lt>stevan@iinteractive.comE<gt>
219 =head1 COPYRIGHT AND LICENSE
221 Copyright 2006 by Infinity Interactive, Inc.
223 L<http://www.iinteractive.com>
225 This library is free software; you can redistribute it and/or modify
226 it under the same terms as Perl itself.