2 package Moose::Meta::TypeConstraint;
8 use overload '""' => sub { shift->name }, # stringify to tc name
12 use Scalar::Util qw(blessed refaddr);
14 our $VERSION = '0.53';
15 our $AUTHORITY = 'cpan:STEVAN';
17 __PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
18 __PACKAGE__->meta->add_attribute('parent' => (
20 predicate => 'has_parent',
23 my $null_constraint = sub { 1 };
24 __PACKAGE__->meta->add_attribute('constraint' => (
25 reader => 'constraint',
26 writer => '_set_constraint',
27 default => sub { $null_constraint }
29 __PACKAGE__->meta->add_attribute('message' => (
30 accessor => 'message',
31 predicate => 'has_message'
33 __PACKAGE__->meta->add_attribute('coercion' => (
34 accessor => 'coercion',
35 predicate => 'has_coercion'
37 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
38 init_arg => 'optimized',
39 accessor => 'hand_optimized_type_constraint',
40 predicate => 'has_hand_optimized_type_constraint',
50 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
51 accessor => '_compiled_type_constraint',
52 predicate => '_has_compiled_type_constraint'
54 __PACKAGE__->meta->add_attribute('package_defined_in' => (
55 accessor => '_package_defined_in'
60 my $self = $class->meta->new_object(@_);
61 $self->compile_type_constraint()
62 unless $self->_has_compiled_type_constraint;
66 sub coerce { ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_) }
67 sub check { $_[0]->_compiled_type_constraint->($_[1]) ? 1 : undef }
69 my ($self, $value) = @_;
70 if ($self->_compiled_type_constraint->($value)) {
74 $self->get_message($value);
79 my ($self, $value) = @_;
80 $value = (defined $value ? overload::StrVal($value) : 'undef');
81 if (my $msg = $self->message) {
83 return $msg->($value);
86 return "Validation failed for '" . $self->name . "' failed with value $value";
90 ## type predicates ...
93 my ( $self, $type_or_name ) = @_;
95 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
97 return 1 if refaddr($self) == refaddr($other);
99 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
100 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
103 return unless $self->constraint == $other->constraint;
105 if ( $self->has_parent ) {
106 return unless $other->has_parent;
107 return unless $self->parent->equals( $other->parent );
109 return if $other->has_parent;
116 my ($self, $type_or_name) = @_;
118 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
120 ($self->equals($type) || $self->is_subtype_of($type));
124 my ($self, $type_or_name) = @_;
126 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
130 while (my $parent = $current->parent) {
131 return 1 if $parent->equals($type);
138 ## compiling the type constraint
140 sub compile_type_constraint {
142 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
145 ## type compilers ...
147 sub _actually_compile_type_constraint {
150 return $self->_compile_hand_optimized_type_constraint
151 if $self->has_hand_optimized_type_constraint;
153 my $check = $self->constraint;
155 || confess "Could not compile type constraint '"
157 . "' because no constraint check";
159 return $self->_compile_subtype($check)
160 if $self->has_parent;
162 return $self->_compile_type($check);
165 sub _compile_hand_optimized_type_constraint {
168 my $type_constraint = $self->hand_optimized_type_constraint;
170 confess unless ref $type_constraint;
172 return $type_constraint;
175 sub _compile_subtype {
176 my ($self, $check) = @_;
178 # gather all the parent constraintss in order
180 my $optimized_parent;
181 foreach my $parent ($self->_collect_all_parents) {
182 # if a parent is optimized, the optimized constraint already includes
183 # all of its parents tcs, so we can break the loop
184 if ($parent->has_hand_optimized_type_constraint) {
185 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
189 push @parents => $parent->constraint;
193 @parents = grep { $_ != $null_constraint } reverse @parents;
195 unless ( @parents ) {
196 return $self->_compile_type($check);
197 } elsif( $optimized_parent and @parents == 1 ) {
198 # the case of just one optimized parent is optimized to prevent
199 # looping and the unnecessary localization
200 if ( $check == $null_constraint ) {
201 return $optimized_parent;
203 return Class::MOP::subname($self->name, sub {
204 return undef unless $optimized_parent->($_[0]);
210 # general case, check all the constraints, from the first parent to ourselves
211 my @checks = @parents;
212 push @checks, $check if $check != $null_constraint;
213 return Class::MOP::subname($self->name => sub {
215 foreach my $check (@checks) {
216 return undef unless $check->($_[0]);
224 my ($self, $check) = @_;
226 return $check if $check == $null_constraint; # Item, Any
228 return Class::MOP::subname($self->name => sub {
236 sub _collect_all_parents {
239 my $current = $self->parent;
240 while (defined $current) {
241 push @parents => $current;
242 $current = $current->parent;
247 ## this should get deprecated actually ...
249 sub union { Carp::croak "DEPRECATED" }
259 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
263 For the most part, the only time you will ever encounter an
264 instance of this class is if you are doing some serious deep
265 introspection. This API should not be considered final, but
266 it is B<highly unlikely> that this will matter to a regular
269 If you wish to use features at this depth, please come to the
270 #moose IRC channel on irc.perl.org and we can talk :)
280 =item B<equals ($type_name_or_object)>
282 =item B<is_a_type_of ($type_name_or_object)>
284 This checks the current type name, and if it does not match,
285 checks if it is a subtype of it.
287 =item B<is_subtype_of ($type_name_or_object)>
289 =item B<compile_type_constraint>
291 =item B<coerce ($value)>
293 This will apply the type-coercion if applicable.
295 =item B<check ($value)>
297 This method will return a true (C<1>) if the C<$value> passes the
298 constraint, and false (C<0>) otherwise.
300 =item B<validate ($value)>
302 This method is similar to C<check>, but it deals with the error
303 message. If the C<$value> passes the constraint, C<undef> will be
304 returned. If the C<$value> does B<not> pass the constraint, then
305 the C<message> will be used to construct a custom error message.
321 =item B<get_message ($value)>
323 =item B<has_coercion>
327 =item B<hand_optimized_type_constraint>
329 =item B<has_hand_optimized_type_constraint>
333 =head2 DEPRECATED METHOD
339 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
346 All complex software has bugs lurking in it, and this module is no
347 exception. If you find a bug please either email me, or add the bug
352 Stevan Little E<lt>stevan@iinteractive.comE<gt>
354 =head1 COPYRIGHT AND LICENSE
356 Copyright 2006-2008 by Infinity Interactive, Inc.
358 L<http://www.iinteractive.com>
360 This library is free software; you can redistribute it and/or modify
361 it under the same terms as Perl itself.