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);
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);
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);
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 =item B<is_a_type_of ($type_name_or_object)>
287 This checks the current type name, and if it does not match,
288 checks if it is a subtype of it.
290 =item B<is_subtype_of ($type_name_or_object)>
292 =item B<compile_type_constraint>
294 =item B<coerce ($value)>
296 This will apply the type-coercion if applicable.
298 =item B<check ($value)>
300 This method will return a true (C<1>) if the C<$value> passes the
301 constraint, and false (C<0>) otherwise.
303 =item B<validate ($value)>
305 This method is similar to C<check>, but it deals with the error
306 message. If the C<$value> passes the constraint, C<undef> will be
307 returned. If the C<$value> does B<not> pass the constraint, then
308 the C<message> will be used to construct a custom error message.
324 =item B<get_message ($value)>
326 =item B<has_coercion>
330 =item B<hand_optimized_type_constraint>
332 =item B<has_hand_optimized_type_constraint>
336 =head2 DEPRECATED METHOD
342 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
349 All complex software has bugs lurking in it, and this module is no
350 exception. If you find a bug please either email me, or add the bug
355 Stevan Little E<lt>stevan@iinteractive.comE<gt>
357 =head1 COPYRIGHT AND LICENSE
359 Copyright 2006-2008 by Infinity Interactive, Inc.
361 L<http://www.iinteractive.com>
363 This library is free software; you can redistribute it and/or modify
364 it under the same terms as Perl itself.