2 package Moose::Meta::TypeConstraint;
8 use overload '""' => sub { shift->name }, # stringify to tc name
12 use Scalar::Util qw(blessed refaddr);
14 our $VERSION = '0.13';
15 our $AUTHORITY = 'cpan:STEVAN';
17 __PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
18 __PACKAGE__->meta->add_attribute('parent' => (
20 predicate => 'has_parent',
22 __PACKAGE__->meta->add_attribute('constraint' => (
23 reader => 'constraint',
24 writer => '_set_constraint',
25 default => sub { sub { 1 } }
27 __PACKAGE__->meta->add_attribute('message' => (
28 accessor => 'message',
29 predicate => 'has_message'
31 __PACKAGE__->meta->add_attribute('coercion' => (
32 accessor => 'coercion',
33 predicate => 'has_coercion'
35 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
36 init_arg => 'optimized',
37 accessor => 'hand_optimized_type_constraint',
38 predicate => 'has_hand_optimized_type_constraint',
48 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
49 accessor => '_compiled_type_constraint',
50 predicate => '_has_compiled_type_constraint'
52 __PACKAGE__->meta->add_attribute('package_defined_in' => (
53 accessor => '_package_defined_in'
58 my $self = $class->meta->new_object(@_);
59 $self->compile_type_constraint()
60 unless $self->_has_compiled_type_constraint;
64 sub coerce { ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_) }
65 sub check { $_[0]->_compiled_type_constraint->($_[1]) ? 1 : undef }
67 my ($self, $value) = @_;
68 if ($self->_compiled_type_constraint->($value)) {
72 $self->get_message($value);
77 my ($self, $value) = @_;
78 $value = (defined $value ? overload::StrVal($value) : 'undef');
79 if (my $msg = $self->message) {
81 return $msg->($value);
84 return "Validation failed for '" . $self->name . "' failed with value $value";
88 ## type predicates ...
91 my ( $self, $type_or_name ) = @_;
93 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
95 return 1 if refaddr($self) == refaddr($other);
97 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
98 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
101 return unless $self->constraint == $other->constraint;
103 if ( $self->has_parent ) {
104 return unless $other->has_parent;
105 return unless $self->parent->equals( $other->parent );
107 return if $other->has_parent;
114 my ($self, $type_or_name) = @_;
116 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
118 ($self->equals($type) || $self->is_subtype_of($type));
122 my ($self, $type_or_name) = @_;
124 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
128 while (my $parent = $current->parent) {
129 return 1 if $parent->equals($type);
136 ## compiling the type constraint
138 sub compile_type_constraint {
140 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
143 ## type compilers ...
145 sub _actually_compile_type_constraint {
148 return $self->_compile_hand_optimized_type_constraint
149 if $self->has_hand_optimized_type_constraint;
151 my $check = $self->constraint;
153 || confess "Could not compile type constraint '"
155 . "' because no constraint check";
157 return $self->_compile_subtype($check)
158 if $self->has_parent;
160 return $self->_compile_type($check);
163 sub _compile_hand_optimized_type_constraint {
166 my $type_constraint = $self->hand_optimized_type_constraint;
168 confess unless ref $type_constraint;
170 return $type_constraint;
173 sub _compile_subtype {
174 my ($self, $check) = @_;
176 # so we gather all the parents in order
177 # and grab their constraints ...
179 foreach my $parent ($self->_collect_all_parents) {
180 if ($parent->has_hand_optimized_type_constraint) {
181 unshift @parents => $parent->hand_optimized_type_constraint;
185 unshift @parents => $parent->constraint;
189 # then we compile them to run without
190 # having to recurse as we did before
191 return Class::MOP::subname($self->name => sub {
193 foreach my $parent (@parents) {
194 return undef unless $parent->($_[0]);
196 return undef unless $check->($_[0]);
202 my ($self, $check) = @_;
203 return Class::MOP::subname($self->name => sub {
205 return undef unless $check->($_[0]);
212 sub _collect_all_parents {
215 my $current = $self->parent;
216 while (defined $current) {
217 push @parents => $current;
218 $current = $current->parent;
223 ## this should get deprecated actually ...
225 sub union { Carp::croak "DEPRECATED" }
235 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
239 For the most part, the only time you will ever encounter an
240 instance of this class is if you are doing some serious deep
241 introspection. This API should not be considered final, but
242 it is B<highly unlikely> that this will matter to a regular
245 If you wish to use features at this depth, please come to the
246 #moose IRC channel on irc.perl.org and we can talk :)
256 =item B<equals ($type_name_or_object)>
258 =item B<is_a_type_of ($type_name_or_object)>
260 This checks the current type name, and if it does not match,
261 checks if it is a subtype of it.
263 =item B<is_subtype_of ($type_name_or_object)>
265 =item B<compile_type_constraint>
267 =item B<coerce ($value)>
269 This will apply the type-coercion if applicable.
271 =item B<check ($value)>
273 This method will return a true (C<1>) if the C<$value> passes the
274 constraint, and false (C<0>) otherwise.
276 =item B<validate ($value)>
278 This method is similar to C<check>, but it deals with the error
279 message. If the C<$value> passes the constraint, C<undef> will be
280 returned. If the C<$value> does B<not> pass the constraint, then
281 the C<message> will be used to construct a custom error message.
297 =item B<get_message ($value)>
299 =item B<has_coercion>
303 =item B<hand_optimized_type_constraint>
305 =item B<has_hand_optimized_type_constraint>
309 =head2 DEPRECATED METHOD
315 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
322 All complex software has bugs lurking in it, and this module is no
323 exception. If you find a bug please either email me, or add the bug
328 Stevan Little E<lt>stevan@iinteractive.comE<gt>
330 =head1 COPYRIGHT AND LICENSE
332 Copyright 2006-2008 by Infinity Interactive, Inc.
334 L<http://www.iinteractive.com>
336 This library is free software; you can redistribute it and/or modify
337 it under the same terms as Perl itself.