2 package Moose::Meta::TypeConstraint;
8 use overload '""' => sub { shift->name }, # stringify to tc name
11 use Sub::Name 'subname';
13 use Scalar::Util 'blessed';
15 our $VERSION = '0.10';
16 our $AUTHORITY = 'cpan:STEVAN';
18 __PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
19 __PACKAGE__->meta->add_attribute('parent' => (
21 predicate => 'has_parent',
23 __PACKAGE__->meta->add_attribute('constraint' => (
24 reader => 'constraint',
25 writer => '_set_constraint',
26 default => sub { sub { 1 } }
28 __PACKAGE__->meta->add_attribute('message' => (
29 accessor => 'message',
30 predicate => 'has_message'
32 __PACKAGE__->meta->add_attribute('coercion' => (
33 accessor => 'coercion',
34 predicate => 'has_coercion'
36 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
37 init_arg => 'optimized',
38 accessor => 'hand_optimized_type_constraint',
39 predicate => 'has_hand_optimized_type_constraint',
44 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
45 accessor => '_compiled_type_constraint',
46 predicate => '_has_compiled_type_constraint'
48 __PACKAGE__->meta->add_attribute('package_defined_in' => (
49 accessor => '_package_defined_in'
54 my $self = $class->meta->new_object(@_);
55 $self->compile_type_constraint()
56 unless $self->_has_compiled_type_constraint;
60 sub coerce { ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_) }
61 sub check { $_[0]->_compiled_type_constraint->($_[1]) }
63 my ($self, $value) = @_;
64 if ($self->_compiled_type_constraint->($value)) {
68 if ($self->has_message) {
70 return $self->message->($value);
73 return "Validation failed for '" . $self->name . "' failed";
78 ## type predicates ...
81 my ($self, $type_name) = @_;
82 ($self->name eq $type_name || $self->is_subtype_of($type_name));
86 my ($self, $type_name) = @_;
88 while (my $parent = $current->parent) {
89 return 1 if $parent->name eq $type_name;
95 ## compiling the type constraint
97 sub compile_type_constraint {
99 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
102 ## type compilers ...
104 sub _actually_compile_type_constraint {
107 return $self->_compile_hand_optimized_type_constraint
108 if $self->has_hand_optimized_type_constraint;
110 my $check = $self->constraint;
112 || confess "Could not compile type constraint '"
114 . "' because no constraint check";
116 return $self->_compile_subtype($check)
117 if $self->has_parent;
119 return $self->_compile_type($check);
122 sub _compile_hand_optimized_type_constraint {
125 my $type_constraint = $self->hand_optimized_type_constraint;
128 confess unless ref $type_constraint;
129 return undef unless $type_constraint->($_[0]);
134 sub _compile_subtype {
135 my ($self, $check) = @_;
137 # so we gather all the parents in order
138 # and grab their constraints ...
140 foreach my $parent ($self->_collect_all_parents) {
141 if ($parent->has_hand_optimized_type_constraint) {
142 unshift @parents => $parent->hand_optimized_type_constraint;
146 unshift @parents => $parent->constraint;
150 # then we compile them to run without
151 # having to recurse as we did before
152 return subname $self->name => sub {
154 foreach my $parent (@parents) {
155 return undef unless $parent->($_[0]);
157 return undef unless $check->($_[0]);
163 my ($self, $check) = @_;
164 return subname $self->name => sub {
166 return undef unless $check->($_[0]);
173 sub _collect_all_parents {
176 my $current = $self->parent;
177 while (defined $current) {
178 push @parents => $current;
179 $current = $current->parent;
184 ## this should get deprecated actually ...
186 sub union { die "DEPRECATED" }
196 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
200 For the most part, the only time you will ever encounter an
201 instance of this class is if you are doing some serious deep
202 introspection. This API should not be considered final, but
203 it is B<highly unlikely> that this will matter to a regular
206 If you wish to use features at this depth, please come to the
207 #moose IRC channel on irc.perl.org and we can talk :)
217 =item B<is_a_type_of ($type_name)>
219 This checks the current type name, and if it does not match,
220 checks if it is a subtype of it.
222 =item B<is_subtype_of ($type_name)>
224 =item B<compile_type_constraint>
226 =item B<coerce ($value)>
228 This will apply the type-coercion if applicable.
230 =item B<check ($value)>
232 This method will return a true (C<1>) if the C<$value> passes the
233 constraint, and false (C<0>) otherwise.
235 =item B<validate ($value)>
237 This method is similar to C<check>, but it deals with the error
238 message. If the C<$value> passes the constraint, C<undef> will be
239 returned. If the C<$value> does B<not> pass the constraint, then
240 the C<message> will be used to construct a custom error message.
254 =item B<has_coercion>
258 =item B<hand_optimized_type_constraint>
260 =item B<has_hand_optimized_type_constraint>
264 =head2 DEPRECATED METHOD
270 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
277 All complex software has bugs lurking in it, and this module is no
278 exception. If you find a bug please either email me, or add the bug
283 Stevan Little E<lt>stevan@iinteractive.comE<gt>
285 =head1 COPYRIGHT AND LICENSE
287 Copyright 2006-2008 by Infinity Interactive, Inc.
289 L<http://www.iinteractive.com>
291 This library is free software; you can redistribute it and/or modify
292 it under the same terms as Perl itself.