2 package Moose::Meta::TypeConstraint;
8 use overload '""' => sub { shift->name }, # stringify to tc name
11 use Scalar::Util qw(blessed refaddr);
13 use base qw(Class::MOP::Object);
15 our $VERSION = '0.67';
16 $VERSION = eval $VERSION;
17 our $AUTHORITY = 'cpan:STEVAN';
19 __PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
20 __PACKAGE__->meta->add_attribute('parent' => (
22 predicate => 'has_parent',
25 my $null_constraint = sub { 1 };
26 __PACKAGE__->meta->add_attribute('constraint' => (
27 reader => 'constraint',
28 writer => '_set_constraint',
29 default => sub { $null_constraint }
31 __PACKAGE__->meta->add_attribute('message' => (
32 accessor => 'message',
33 predicate => 'has_message'
35 __PACKAGE__->meta->add_attribute('coercion' => (
36 accessor => 'coercion',
37 predicate => 'has_coercion'
39 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
40 init_arg => 'optimized',
41 accessor => 'hand_optimized_type_constraint',
42 predicate => 'has_hand_optimized_type_constraint',
52 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
53 accessor => '_compiled_type_constraint',
54 predicate => '_has_compiled_type_constraint'
56 __PACKAGE__->meta->add_attribute('package_defined_in' => (
57 accessor => '_package_defined_in'
62 my ($first, @rest) = @_;
63 my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
64 $args{name} = $args{name} ? "$args{name}" : "__ANON__";
66 my $self = $class->_new(%args);
67 $self->compile_type_constraint()
68 unless $self->_has_compiled_type_constraint;
74 sub coerce { ((shift)->coercion || Moose->throw_error("Cannot coerce without a type coercion"))->coerce(@_) }
77 my ($self, @args) = @_;
78 my $constraint_subref = $self->_compiled_type_constraint;
79 return $constraint_subref->(@args) ? 1 : undef;
83 my ($self, $value) = @_;
84 if ($self->_compiled_type_constraint->($value)) {
88 $self->get_message($value);
93 my ($self, $value) = @_;
94 if (my $msg = $self->message) {
96 return $msg->($value);
99 $value = (defined $value ? overload::StrVal($value) : 'undef');
100 return "Validation failed for '" . $self->name . "' failed with value $value";
104 ## type predicates ...
107 my ( $self, $type_or_name ) = @_;
109 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
111 return 1 if refaddr($self) == refaddr($other);
113 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
114 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
117 return unless $self->constraint == $other->constraint;
119 if ( $self->has_parent ) {
120 return unless $other->has_parent;
121 return unless $self->parent->equals( $other->parent );
123 return if $other->has_parent;
130 my ($self, $type_or_name) = @_;
132 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
134 ($self->equals($type) || $self->is_subtype_of($type));
138 my ($self, $type_or_name) = @_;
140 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
144 while (my $parent = $current->parent) {
145 return 1 if $parent->equals($type);
152 ## compiling the type constraint
154 sub compile_type_constraint {
156 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
159 ## type compilers ...
161 sub _actually_compile_type_constraint {
164 return $self->_compile_hand_optimized_type_constraint
165 if $self->has_hand_optimized_type_constraint;
167 my $check = $self->constraint;
169 || Moose->throw_error("Could not compile type constraint '"
171 . "' because no constraint check");
173 return $self->_compile_subtype($check)
174 if $self->has_parent;
176 return $self->_compile_type($check);
179 sub _compile_hand_optimized_type_constraint {
182 my $type_constraint = $self->hand_optimized_type_constraint;
184 Moose->throw_error("Hand optimized type constraint is not a code reference") unless ref $type_constraint;
186 return $type_constraint;
189 sub _compile_subtype {
190 my ($self, $check) = @_;
192 # gather all the parent constraintss in order
194 my $optimized_parent;
195 foreach my $parent ($self->_collect_all_parents) {
196 # if a parent is optimized, the optimized constraint already includes
197 # all of its parents tcs, so we can break the loop
198 if ($parent->has_hand_optimized_type_constraint) {
199 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
203 push @parents => $parent->constraint;
207 @parents = grep { $_ != $null_constraint } reverse @parents;
209 unless ( @parents ) {
210 return $self->_compile_type($check);
211 } elsif( $optimized_parent and @parents == 1 ) {
212 # the case of just one optimized parent is optimized to prevent
213 # looping and the unnecessary localization
214 if ( $check == $null_constraint ) {
215 return $optimized_parent;
217 return Class::MOP::subname($self->name, sub {
218 return undef unless $optimized_parent->($_[0]);
225 # general case, check all the constraints, from the first parent to ourselves
226 my @checks = @parents;
227 push @checks, $check if $check != $null_constraint;
228 return Class::MOP::subname($self->name => sub {
231 foreach my $check (@checks) {
232 return undef unless $check->(@args);
240 my ($self, $check) = @_;
242 return $check if $check == $null_constraint; # Item, Any
244 return Class::MOP::subname($self->name => sub {
253 sub _collect_all_parents {
256 my $current = $self->parent;
257 while (defined $current) {
258 push @parents => $current;
259 $current = $current->parent;
264 sub create_child_type {
265 my ($self, %opts) = @_;
266 my $class = ref $self;
267 return $class->new(%opts, parent => $self);
270 ## this should get deprecated actually ...
272 sub union { Carp::croak "DEPRECATED" }
282 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
286 For the most part, the only time you will ever encounter an
287 instance of this class is if you are doing some serious deep
288 introspection. This API should not be considered final, but
289 it is B<highly unlikely> that this will matter to a regular
292 If you wish to use features at this depth, please come to the
293 #moose IRC channel on irc.perl.org and we can talk :)
303 =item B<equals ($type_name_or_object)>
305 This checks the current type against the supplied type (only).
306 Returns false if the two types are not equal. It also returns false if
307 you provide the type as a name, and the type name isn't found in the
310 =item B<is_a_type_of ($type_name_or_object)>
312 This checks the current type against the supplied type, or if the
313 current type is a sub-type of the type name or object supplied. It
314 also returns false if you provide the type as a name, and the type
315 name isn't found in the type registry.
317 =item B<is_subtype_of ($type_name_or_object)>
319 This checks the current type is a sub-type of the type name or object
320 supplied. It also returns false if you provide the type as a name, and
321 the type name isn't found in the type registry.
323 =item B<compile_type_constraint>
325 =item B<coerce ($value)>
327 This will apply the type-coercion if applicable.
329 =item B<check ($value)>
331 This method will return a true (C<1>) if the C<$value> passes the
332 constraint, and false (C<0>) otherwise.
334 =item B<validate ($value)>
336 This method is similar to C<check>, but it deals with the error
337 message. If the C<$value> passes the constraint, C<undef> will be
338 returned. If the C<$value> does B<not> pass the constraint, then
339 the C<message> will be used to construct a custom error message.
343 The name of the type in the global type registry.
347 This type's parent type.
351 Returns true if this type has a parent type.
355 Synonym for C<parent>.
359 Returns this type's constraint. This is the value of C<where> provided
360 when defining a type.
364 Returns true if this type has a message.
368 Returns this type's message.
370 =item B<get_message ($value)>
372 Generate message for $value.
374 =item B<has_coercion>
376 Returns true if this type has a coercion.
380 Returns this type's L<Moose::Meta::TypeCoercion> if one exists.
382 =item B<hand_optimized_type_constraint>
384 =item B<has_hand_optimized_type_constraint>
386 =item B<create_child_type>
390 =head2 DEPRECATED METHOD
396 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
403 All complex software has bugs lurking in it, and this module is no
404 exception. If you find a bug please either email me, or add the bug
409 Stevan Little E<lt>stevan@iinteractive.comE<gt>
411 =head1 COPYRIGHT AND LICENSE
413 Copyright 2006-2009 by Infinity Interactive, Inc.
415 L<http://www.iinteractive.com>
417 This library is free software; you can redistribute it and/or modify
418 it under the same terms as Perl itself.