2 package Moose::Meta::TypeConstraint;
8 use overload '""' => sub { shift->name }, # stringify to tc name
12 use Scalar::Util qw(blessed refaddr);
14 use base qw(Class::MOP::Object);
16 our $VERSION = '0.55_01';
17 $VERSION = eval $VERSION;
18 our $AUTHORITY = 'cpan:STEVAN';
20 __PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
21 __PACKAGE__->meta->add_attribute('parent' => (
23 predicate => 'has_parent',
26 my $null_constraint = sub { 1 };
27 __PACKAGE__->meta->add_attribute('constraint' => (
28 reader => 'constraint',
29 writer => '_set_constraint',
30 default => sub { $null_constraint }
32 __PACKAGE__->meta->add_attribute('message' => (
33 accessor => 'message',
34 predicate => 'has_message'
36 __PACKAGE__->meta->add_attribute('coercion' => (
37 accessor => 'coercion',
38 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 $self = $class->_new(@_);
64 $self->compile_type_constraint()
65 unless $self->_has_compiled_type_constraint;
69 sub coerce { ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_) }
70 sub check { $_[0]->_compiled_type_constraint->($_[1]) ? 1 : undef }
72 my ($self, $value) = @_;
73 if ($self->_compiled_type_constraint->($value)) {
77 $self->get_message($value);
82 my ($self, $value) = @_;
83 if (my $msg = $self->message) {
85 return $msg->($value);
88 $value = (defined $value ? overload::StrVal($value) : 'undef');
89 return "Validation failed for '" . $self->name . "' failed with value $value";
93 ## type predicates ...
96 my ( $self, $type_or_name ) = @_;
98 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
100 return 1 if refaddr($self) == refaddr($other);
102 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
103 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
106 return unless $self->constraint == $other->constraint;
108 if ( $self->has_parent ) {
109 return unless $other->has_parent;
110 return unless $self->parent->equals( $other->parent );
112 return if $other->has_parent;
119 my ($self, $type_or_name) = @_;
121 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
123 ($self->equals($type) || $self->is_subtype_of($type));
127 my ($self, $type_or_name) = @_;
129 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
133 while (my $parent = $current->parent) {
134 return 1 if $parent->equals($type);
141 ## compiling the type constraint
143 sub compile_type_constraint {
145 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
148 ## type compilers ...
150 sub _actually_compile_type_constraint {
153 return $self->_compile_hand_optimized_type_constraint
154 if $self->has_hand_optimized_type_constraint;
156 my $check = $self->constraint;
158 || confess "Could not compile type constraint '"
160 . "' because no constraint check";
162 return $self->_compile_subtype($check)
163 if $self->has_parent;
165 return $self->_compile_type($check);
168 sub _compile_hand_optimized_type_constraint {
171 my $type_constraint = $self->hand_optimized_type_constraint;
173 confess unless ref $type_constraint;
175 return $type_constraint;
178 sub _compile_subtype {
179 my ($self, $check) = @_;
181 # gather all the parent constraintss in order
183 my $optimized_parent;
184 foreach my $parent ($self->_collect_all_parents) {
185 # if a parent is optimized, the optimized constraint already includes
186 # all of its parents tcs, so we can break the loop
187 if ($parent->has_hand_optimized_type_constraint) {
188 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
192 push @parents => $parent->constraint;
196 @parents = grep { $_ != $null_constraint } reverse @parents;
198 unless ( @parents ) {
199 return $self->_compile_type($check);
200 } elsif( $optimized_parent and @parents == 1 ) {
201 # the case of just one optimized parent is optimized to prevent
202 # looping and the unnecessary localization
203 if ( $check == $null_constraint ) {
204 return $optimized_parent;
206 return Class::MOP::subname($self->name, sub {
207 return undef unless $optimized_parent->($_[0]);
213 # general case, check all the constraints, from the first parent to ourselves
214 my @checks = @parents;
215 push @checks, $check if $check != $null_constraint;
216 return Class::MOP::subname($self->name => sub {
218 foreach my $check (@checks) {
219 return undef unless $check->($_[0]);
227 my ($self, $check) = @_;
229 return $check if $check == $null_constraint; # Item, Any
231 return Class::MOP::subname($self->name => sub {
239 sub _collect_all_parents {
242 my $current = $self->parent;
243 while (defined $current) {
244 push @parents => $current;
245 $current = $current->parent;
250 ## this should get deprecated actually ...
252 sub union { Carp::croak "DEPRECATED" }
262 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
266 For the most part, the only time you will ever encounter an
267 instance of this class is if you are doing some serious deep
268 introspection. This API should not be considered final, but
269 it is B<highly unlikely> that this will matter to a regular
272 If you wish to use features at this depth, please come to the
273 #moose IRC channel on irc.perl.org and we can talk :)
283 =item B<equals ($type_name_or_object)>
285 This checks the current type against the supplied type (only).
286 Returns false either if the type name or object supplied
287 does not match, or if a type name isn't found in the type registry.
289 =item B<is_a_type_of ($type_name_or_object)>
291 This checks the current type against the supplied type, or if the
292 current type is a sub-type of the type name or object supplied.
293 Returns false if the current type is not descended from the supplied
294 type, of if the supplied type isn't found in the type registry.
296 =item B<is_subtype_of ($type_name_or_object)>
298 This checks the current type is a sub-type of the type name or object supplied.
299 Returns false if the current type is not descended from the supplied
300 type, of if the supplied type isn't found in the type registry.
302 =item B<compile_type_constraint>
304 =item B<coerce ($value)>
306 This will apply the type-coercion if applicable.
308 =item B<check ($value)>
310 This method will return a true (C<1>) if the C<$value> passes the
311 constraint, and false (C<0>) otherwise.
313 =item B<validate ($value)>
315 This method is similar to C<check>, but it deals with the error
316 message. If the C<$value> passes the constraint, C<undef> will be
317 returned. If the C<$value> does B<not> pass the constraint, then
318 the C<message> will be used to construct a custom error message.
322 The name of the type in the global type registry.
326 The parent type of this type.
330 If this type has a parent type.
340 =item B<get_message ($value)>
342 =item B<has_coercion>
346 =item B<hand_optimized_type_constraint>
348 =item B<has_hand_optimized_type_constraint>
352 =head2 DEPRECATED METHOD
358 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
365 All complex software has bugs lurking in it, and this module is no
366 exception. If you find a bug please either email me, or add the bug
371 Stevan Little E<lt>stevan@iinteractive.comE<gt>
373 =head1 COPYRIGHT AND LICENSE
375 Copyright 2006-2008 by Infinity Interactive, Inc.
377 L<http://www.iinteractive.com>
379 This library is free software; you can redistribute it and/or modify
380 it under the same terms as Perl itself.