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]) ? 1 : undef }
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;
127 confess unless ref $type_constraint;
129 return $type_constraint;
132 sub _compile_subtype {
133 my ($self, $check) = @_;
135 # so we gather all the parents in order
136 # and grab their constraints ...
138 foreach my $parent ($self->_collect_all_parents) {
139 if ($parent->has_hand_optimized_type_constraint) {
140 unshift @parents => $parent->hand_optimized_type_constraint;
144 unshift @parents => $parent->constraint;
148 # then we compile them to run without
149 # having to recurse as we did before
150 return subname $self->name => sub {
152 foreach my $parent (@parents) {
153 return undef unless $parent->($_[0]);
155 return undef unless $check->($_[0]);
161 my ($self, $check) = @_;
162 return subname $self->name => sub {
164 return undef unless $check->($_[0]);
171 sub _collect_all_parents {
174 my $current = $self->parent;
175 while (defined $current) {
176 push @parents => $current;
177 $current = $current->parent;
182 ## this should get deprecated actually ...
184 sub union { die "DEPRECATED" }
194 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
198 For the most part, the only time you will ever encounter an
199 instance of this class is if you are doing some serious deep
200 introspection. This API should not be considered final, but
201 it is B<highly unlikely> that this will matter to a regular
204 If you wish to use features at this depth, please come to the
205 #moose IRC channel on irc.perl.org and we can talk :)
215 =item B<is_a_type_of ($type_name)>
217 This checks the current type name, and if it does not match,
218 checks if it is a subtype of it.
220 =item B<is_subtype_of ($type_name)>
222 =item B<compile_type_constraint>
224 =item B<coerce ($value)>
226 This will apply the type-coercion if applicable.
228 =item B<check ($value)>
230 This method will return a true (C<1>) if the C<$value> passes the
231 constraint, and false (C<0>) otherwise.
233 =item B<validate ($value)>
235 This method is similar to C<check>, but it deals with the error
236 message. If the C<$value> passes the constraint, C<undef> will be
237 returned. If the C<$value> does B<not> pass the constraint, then
238 the C<message> will be used to construct a custom error message.
252 =item B<has_coercion>
256 =item B<hand_optimized_type_constraint>
258 =item B<has_hand_optimized_type_constraint>
262 =head2 DEPRECATED METHOD
268 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
275 All complex software has bugs lurking in it, and this module is no
276 exception. If you find a bug please either email me, or add the bug
281 Stevan Little E<lt>stevan@iinteractive.comE<gt>
283 =head1 COPYRIGHT AND LICENSE
285 Copyright 2006-2008 by Infinity Interactive, Inc.
287 L<http://www.iinteractive.com>
289 This library is free software; you can redistribute it and/or modify
290 it under the same terms as Perl itself.