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.60';
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'
39 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
40 init_arg => 'optimized',
41 accessor => 'hand_optimized_type_constraint',
42 predicate => 'has_hand_optimized_type_constraint',
52 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
53 accessor => '_compiled_type_constraint',
54 predicate => '_has_compiled_type_constraint'
56 __PACKAGE__->meta->add_attribute('package_defined_in' => (
57 accessor => '_package_defined_in'
62 my $self = $class->_new(@_);
63 $self->compile_type_constraint()
64 unless $self->_has_compiled_type_constraint;
68 sub coerce { ((shift)->coercion || Moose->throw_error("Cannot coerce without a type coercion"))->coerce(@_) }
69 sub check { $_[0]->_compiled_type_constraint->($_[1]) ? 1 : undef }
71 my ($self, $value) = @_;
72 if ($self->_compiled_type_constraint->($value)) {
76 $self->get_message($value);
81 my ($self, $value) = @_;
82 if (my $msg = $self->message) {
84 return $msg->($value);
87 $value = (defined $value ? overload::StrVal($value) : 'undef');
88 return "Validation failed for '" . $self->name . "' failed with value $value";
92 ## type predicates ...
95 my ( $self, $type_or_name ) = @_;
97 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
99 return 1 if refaddr($self) == refaddr($other);
101 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
102 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
105 return unless $self->constraint == $other->constraint;
107 if ( $self->has_parent ) {
108 return unless $other->has_parent;
109 return unless $self->parent->equals( $other->parent );
111 return if $other->has_parent;
118 my ($self, $type_or_name) = @_;
120 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
122 ($self->equals($type) || $self->is_subtype_of($type));
126 my ($self, $type_or_name) = @_;
128 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
132 while (my $parent = $current->parent) {
133 return 1 if $parent->equals($type);
140 ## compiling the type constraint
142 sub compile_type_constraint {
144 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
147 ## type compilers ...
149 sub _actually_compile_type_constraint {
152 return $self->_compile_hand_optimized_type_constraint
153 if $self->has_hand_optimized_type_constraint;
155 my $check = $self->constraint;
157 || Moose->throw_error("Could not compile type constraint '"
159 . "' because no constraint check");
161 return $self->_compile_subtype($check)
162 if $self->has_parent;
164 return $self->_compile_type($check);
167 sub _compile_hand_optimized_type_constraint {
170 my $type_constraint = $self->hand_optimized_type_constraint;
172 Moose->throw_error("Hand optimized type constraint is not a code reference") unless ref $type_constraint;
174 return $type_constraint;
177 sub _compile_subtype {
178 my ($self, $check) = @_;
180 # gather all the parent constraintss in order
182 my $optimized_parent;
183 foreach my $parent ($self->_collect_all_parents) {
184 # if a parent is optimized, the optimized constraint already includes
185 # all of its parents tcs, so we can break the loop
186 if ($parent->has_hand_optimized_type_constraint) {
187 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
191 push @parents => $parent->constraint;
195 @parents = grep { $_ != $null_constraint } reverse @parents;
197 unless ( @parents ) {
198 return $self->_compile_type($check);
199 } elsif( $optimized_parent and @parents == 1 ) {
200 # the case of just one optimized parent is optimized to prevent
201 # looping and the unnecessary localization
202 if ( $check == $null_constraint ) {
203 return $optimized_parent;
205 return Class::MOP::subname($self->name, sub {
206 return undef unless $optimized_parent->($_[0]);
212 # general case, check all the constraints, from the first parent to ourselves
213 my @checks = @parents;
214 push @checks, $check if $check != $null_constraint;
215 return Class::MOP::subname($self->name => sub {
217 foreach my $check (@checks) {
218 return undef unless $check->($_[0]);
226 my ($self, $check) = @_;
228 return $check if $check == $null_constraint; # Item, Any
230 return Class::MOP::subname($self->name => sub {
238 sub _collect_all_parents {
241 my $current = $self->parent;
242 while (defined $current) {
243 push @parents => $current;
244 $current = $current->parent;
249 sub create_child_type {
250 my ($self, %opts) = @_;
251 my $class = ref $self;
252 return $class->new(%opts, parent => $self);
255 ## this should get deprecated actually ...
257 sub union { Carp::croak "DEPRECATED" }
267 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
271 For the most part, the only time you will ever encounter an
272 instance of this class is if you are doing some serious deep
273 introspection. This API should not be considered final, but
274 it is B<highly unlikely> that this will matter to a regular
277 If you wish to use features at this depth, please come to the
278 #moose IRC channel on irc.perl.org and we can talk :)
288 =item B<equals ($type_name_or_object)>
290 This checks the current type against the supplied type (only).
291 Returns false if the two types are not equal. It also returns false if
292 you provide the type as a name, and the type name isn't found in the
295 =item B<is_a_type_of ($type_name_or_object)>
297 This checks the current type against the supplied type, or if the
298 current type is a sub-type of the type name or object supplied. It
299 also returns false if you provide the type as a name, and the type
300 name isn't found in the type registry.
302 =item B<is_subtype_of ($type_name_or_object)>
304 This checks the current type is a sub-type of the type name or object
305 supplied. It also returns false if you provide the type as a name, and
306 the type name isn't found in the type registry.
308 =item B<compile_type_constraint>
310 =item B<coerce ($value)>
312 This will apply the type-coercion if applicable.
314 =item B<check ($value)>
316 This method will return a true (C<1>) if the C<$value> passes the
317 constraint, and false (C<0>) otherwise.
319 =item B<validate ($value)>
321 This method is similar to C<check>, but it deals with the error
322 message. If the C<$value> passes the constraint, C<undef> will be
323 returned. If the C<$value> does B<not> pass the constraint, then
324 the C<message> will be used to construct a custom error message.
328 The name of the type in the global type registry.
332 This type's parent type.
336 Returns true if this type has a parent type.
346 =item B<get_message ($value)>
348 =item B<has_coercion>
352 =item B<hand_optimized_type_constraint>
354 =item B<has_hand_optimized_type_constraint>
356 =item B<create_child_type>
360 =head2 DEPRECATED METHOD
366 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
373 All complex software has bugs lurking in it, and this module is no
374 exception. If you find a bug please either email me, or add the bug
379 Stevan Little E<lt>stevan@iinteractive.comE<gt>
381 =head1 COPYRIGHT AND LICENSE
383 Copyright 2006-2008 by Infinity Interactive, Inc.
385 L<http://www.iinteractive.com>
387 This library is free software; you can redistribute it and/or modify
388 it under the same terms as Perl itself.