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.71_01';
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'
40 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
41 init_arg => 'optimized',
42 accessor => 'hand_optimized_type_constraint',
43 predicate => 'has_hand_optimized_type_constraint',
53 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
54 accessor => '_compiled_type_constraint',
55 predicate => '_has_compiled_type_constraint'
57 __PACKAGE__->meta->add_attribute('package_defined_in' => (
58 accessor => '_package_defined_in'
63 my ($first, @rest) = @_;
64 my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
65 $args{name} = $args{name} ? "$args{name}" : "__ANON__";
67 my $self = $class->_new(%args);
68 $self->compile_type_constraint()
69 unless $self->_has_compiled_type_constraint;
78 my $coercion = $self->coercion;
82 Moose->throw_error("Cannot coerce without a type coercion");
85 return $coercion->coerce(@_);
89 my ($self, @args) = @_;
90 my $constraint_subref = $self->_compiled_type_constraint;
91 return $constraint_subref->(@args) ? 1 : undef;
95 my ($self, $value) = @_;
96 if ($self->_compiled_type_constraint->($value)) {
100 $self->get_message($value);
105 my ($self, $value) = @_;
106 if (my $msg = $self->message) {
108 return $msg->($value);
111 $value = (defined $value ? overload::StrVal($value) : 'undef');
112 return "Validation failed for '" . $self->name . "' failed with value $value";
116 ## type predicates ...
119 my ( $self, $type_or_name ) = @_;
121 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
123 return 1 if refaddr($self) == refaddr($other);
125 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
126 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
129 return unless $self->constraint == $other->constraint;
131 if ( $self->has_parent ) {
132 return unless $other->has_parent;
133 return unless $self->parent->equals( $other->parent );
135 return if $other->has_parent;
142 my ($self, $type_or_name) = @_;
144 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
146 ($self->equals($type) || $self->is_subtype_of($type));
150 my ($self, $type_or_name) = @_;
152 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
156 while (my $parent = $current->parent) {
157 return 1 if $parent->equals($type);
164 ## compiling the type constraint
166 sub compile_type_constraint {
168 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
171 ## type compilers ...
173 sub _actually_compile_type_constraint {
176 return $self->_compile_hand_optimized_type_constraint
177 if $self->has_hand_optimized_type_constraint;
179 my $check = $self->constraint;
180 unless ( defined $check ) {
182 Moose->throw_error( "Could not compile type constraint '"
184 . "' because no constraint check" );
187 return $self->_compile_subtype($check)
188 if $self->has_parent;
190 return $self->_compile_type($check);
193 sub _compile_hand_optimized_type_constraint {
196 my $type_constraint = $self->hand_optimized_type_constraint;
198 unless ( ref $type_constraint ) {
200 Carp::confess ("Hand optimized type constraint for " . $self->name . " is not a code reference");
201 Moose->throw_error("Hand optimized type constraint is not a code reference");
204 return $type_constraint;
207 sub _compile_subtype {
208 my ($self, $check) = @_;
210 # gather all the parent constraintss in order
212 my $optimized_parent;
213 foreach my $parent ($self->_collect_all_parents) {
214 # if a parent is optimized, the optimized constraint already includes
215 # all of its parents tcs, so we can break the loop
216 if ($parent->has_hand_optimized_type_constraint) {
217 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
221 push @parents => $parent->constraint;
225 @parents = grep { $_ != $null_constraint } reverse @parents;
227 unless ( @parents ) {
228 return $self->_compile_type($check);
229 } elsif( $optimized_parent and @parents == 1 ) {
230 # the case of just one optimized parent is optimized to prevent
231 # looping and the unnecessary localization
232 if ( $check == $null_constraint ) {
233 return $optimized_parent;
235 return Class::MOP::subname($self->name, sub {
236 return undef unless $optimized_parent->($_[0]);
243 # general case, check all the constraints, from the first parent to ourselves
244 my @checks = @parents;
245 push @checks, $check if $check != $null_constraint;
246 return Class::MOP::subname($self->name => sub {
249 foreach my $check (@checks) {
250 return undef unless $check->(@args);
258 my ($self, $check) = @_;
260 return $check if $check == $null_constraint; # Item, Any
262 return Class::MOP::subname($self->name => sub {
271 sub _collect_all_parents {
274 my $current = $self->parent;
275 while (defined $current) {
276 push @parents => $current;
277 $current = $current->parent;
282 sub create_child_type {
283 my ($self, %opts) = @_;
284 my $class = ref $self;
285 return $class->new(%opts, parent => $self);
288 ## this should get deprecated actually ...
290 sub union { Carp::croak "DEPRECATED" }
300 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
304 For the most part, the only time you will ever encounter an
305 instance of this class is if you are doing some serious deep
306 introspection. This API should not be considered final, but
307 it is B<highly unlikely> that this will matter to a regular
310 If you wish to use features at this depth, please come to the
311 #moose IRC channel on irc.perl.org and we can talk :)
321 =item B<equals ($type_name_or_object)>
323 This checks the current type against the supplied type (only).
324 Returns false if the two types are not equal. It also returns false if
325 you provide the type as a name, and the type name isn't found in the
328 =item B<is_a_type_of ($type_name_or_object)>
330 This checks the current type against the supplied type, or if the
331 current type is a sub-type of the type name or object supplied. It
332 also returns false if you provide the type as a name, and the type
333 name isn't found in the type registry.
335 =item B<is_subtype_of ($type_name_or_object)>
337 This checks the current type is a sub-type of the type name or object
338 supplied. It also returns false if you provide the type as a name, and
339 the type name isn't found in the type registry.
341 =item B<compile_type_constraint>
343 =item B<coerce ($value)>
345 This will apply the type-coercion if applicable.
347 =item B<check ($value)>
349 This method will return a true (C<1>) if the C<$value> passes the
350 constraint, and false (C<0>) otherwise.
352 =item B<validate ($value)>
354 This method is similar to C<check>, but it deals with the error
355 message. If the C<$value> passes the constraint, C<undef> will be
356 returned. If the C<$value> does B<not> pass the constraint, then
357 the C<message> will be used to construct a custom error message.
361 The name of the type in the global type registry.
365 This type's parent type.
369 Returns true if this type has a parent type.
373 Synonym for C<parent>.
377 Returns this type's constraint. This is the value of C<where> provided
378 when defining a type.
382 Returns true if this type has a message.
386 Returns this type's message.
388 =item B<get_message ($value)>
390 Generate message for $value.
392 =item B<has_coercion>
394 Returns true if this type has a coercion.
398 Returns this type's L<Moose::Meta::TypeCoercion> if one exists.
400 =item B<hand_optimized_type_constraint>
402 =item B<has_hand_optimized_type_constraint>
404 =item B<create_child_type>
408 =head2 DEPRECATED METHOD
414 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
421 All complex software has bugs lurking in it, and this module is no
422 exception. If you find a bug please either email me, or add the bug
427 Stevan Little E<lt>stevan@iinteractive.comE<gt>
429 =head1 COPYRIGHT AND LICENSE
431 Copyright 2006-2009 by Infinity Interactive, Inc.
433 L<http://www.iinteractive.com>
435 This library is free software; you can redistribute it and/or modify
436 it under the same terms as Perl itself.