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_02';
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 if the two types are not equal. It also returns false if
287 you provide the type as a name, and the type name isn't found in the
290 =item B<is_a_type_of ($type_name_or_object)>
292 This checks the current type against the supplied type, or if the
293 current type is a sub-type of the type name or object supplied. It
294 also returns false if you provide the type as a name, and the type
295 name isn't found in the type registry.
297 =item B<is_subtype_of ($type_name_or_object)>
299 This checks the current type is a sub-type of the type name or object
300 supplied. It also returns false if you provide the type as a name, and
301 the type name isn't found in the type registry.
303 =item B<compile_type_constraint>
305 =item B<coerce ($value)>
307 This will apply the type-coercion if applicable.
309 =item B<check ($value)>
311 This method will return a true (C<1>) if the C<$value> passes the
312 constraint, and false (C<0>) otherwise.
314 =item B<validate ($value)>
316 This method is similar to C<check>, but it deals with the error
317 message. If the C<$value> passes the constraint, C<undef> will be
318 returned. If the C<$value> does B<not> pass the constraint, then
319 the C<message> will be used to construct a custom error message.
323 The name of the type in the global type registry.
327 This type's parent type.
331 Returns true if this type has a parent type.
341 =item B<get_message ($value)>
343 =item B<has_coercion>
347 =item B<hand_optimized_type_constraint>
349 =item B<has_hand_optimized_type_constraint>
353 =head2 DEPRECATED METHOD
359 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
366 All complex software has bugs lurking in it, and this module is no
367 exception. If you find a bug please either email me, or add the bug
372 Stevan Little E<lt>stevan@iinteractive.comE<gt>
374 =head1 COPYRIGHT AND LICENSE
376 Copyright 2006-2008 by Infinity Interactive, Inc.
378 L<http://www.iinteractive.com>
380 This library is free software; you can redistribute it and/or modify
381 it under the same terms as Perl itself.