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.61';
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 ($first, @rest) = @_;
63 my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
64 $args{name} = $args{name} ? "$args{name}" : "__ANON__";
66 my $self = $class->_new(%args);
67 $self->compile_type_constraint()
68 unless $self->_has_compiled_type_constraint;
74 sub coerce { ((shift)->coercion || Moose->throw_error("Cannot coerce without a type coercion"))->coerce(@_) }
75 sub check { $_[0]->_compiled_type_constraint->($_[1]) ? 1 : undef }
77 my ($self, $value) = @_;
78 if ($self->_compiled_type_constraint->($value)) {
82 $self->get_message($value);
87 my ($self, $value) = @_;
88 if (my $msg = $self->message) {
90 return $msg->($value);
93 $value = (defined $value ? overload::StrVal($value) : 'undef');
94 return "Validation failed for '" . $self->name . "' failed with value $value";
98 ## type predicates ...
101 my ( $self, $type_or_name ) = @_;
103 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
105 return 1 if refaddr($self) == refaddr($other);
107 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
108 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
111 return unless $self->constraint == $other->constraint;
113 if ( $self->has_parent ) {
114 return unless $other->has_parent;
115 return unless $self->parent->equals( $other->parent );
117 return if $other->has_parent;
124 my ($self, $type_or_name) = @_;
126 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
128 ($self->equals($type) || $self->is_subtype_of($type));
132 my ($self, $type_or_name) = @_;
134 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
138 while (my $parent = $current->parent) {
139 return 1 if $parent->equals($type);
146 ## compiling the type constraint
148 sub compile_type_constraint {
150 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
153 ## type compilers ...
155 sub _actually_compile_type_constraint {
158 return $self->_compile_hand_optimized_type_constraint
159 if $self->has_hand_optimized_type_constraint;
161 my $check = $self->constraint;
163 || Moose->throw_error("Could not compile type constraint '"
165 . "' because no constraint check");
167 return $self->_compile_subtype($check)
168 if $self->has_parent;
170 return $self->_compile_type($check);
173 sub _compile_hand_optimized_type_constraint {
176 my $type_constraint = $self->hand_optimized_type_constraint;
178 Moose->throw_error("Hand optimized type constraint is not a code reference") unless ref $type_constraint;
180 return $type_constraint;
183 sub _compile_subtype {
184 my ($self, $check) = @_;
186 # gather all the parent constraintss in order
188 my $optimized_parent;
189 foreach my $parent ($self->_collect_all_parents) {
190 # if a parent is optimized, the optimized constraint already includes
191 # all of its parents tcs, so we can break the loop
192 if ($parent->has_hand_optimized_type_constraint) {
193 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
197 push @parents => $parent->constraint;
201 @parents = grep { $_ != $null_constraint } reverse @parents;
203 unless ( @parents ) {
204 return $self->_compile_type($check);
205 } elsif( $optimized_parent and @parents == 1 ) {
206 # the case of just one optimized parent is optimized to prevent
207 # looping and the unnecessary localization
208 if ( $check == $null_constraint ) {
209 return $optimized_parent;
211 return Class::MOP::subname($self->name, sub {
212 return undef unless $optimized_parent->($_[0]);
218 # general case, check all the constraints, from the first parent to ourselves
219 my @checks = @parents;
220 push @checks, $check if $check != $null_constraint;
221 return Class::MOP::subname($self->name => sub {
223 foreach my $check (@checks) {
224 return undef unless $check->($_[0]);
232 my ($self, $check) = @_;
234 return $check if $check == $null_constraint; # Item, Any
236 return Class::MOP::subname($self->name => sub {
244 sub _collect_all_parents {
247 my $current = $self->parent;
248 while (defined $current) {
249 push @parents => $current;
250 $current = $current->parent;
255 sub create_child_type {
256 my ($self, %opts) = @_;
257 my $class = ref $self;
258 return $class->new(%opts, parent => $self);
261 ## this should get deprecated actually ...
263 sub union { Carp::croak "DEPRECATED" }
273 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
277 For the most part, the only time you will ever encounter an
278 instance of this class is if you are doing some serious deep
279 introspection. This API should not be considered final, but
280 it is B<highly unlikely> that this will matter to a regular
283 If you wish to use features at this depth, please come to the
284 #moose IRC channel on irc.perl.org and we can talk :)
294 =item B<equals ($type_name_or_object)>
296 This checks the current type against the supplied type (only).
297 Returns false if the two types are not equal. It also returns false if
298 you provide the type as a name, and the type name isn't found in the
301 =item B<is_a_type_of ($type_name_or_object)>
303 This checks the current type against the supplied type, or if the
304 current type is a sub-type of the type name or object supplied. It
305 also returns false if you provide the type as a name, and the type
306 name isn't found in the type registry.
308 =item B<is_subtype_of ($type_name_or_object)>
310 This checks the current type is a sub-type of the type name or object
311 supplied. It also returns false if you provide the type as a name, and
312 the type name isn't found in the type registry.
314 =item B<compile_type_constraint>
316 =item B<coerce ($value)>
318 This will apply the type-coercion if applicable.
320 =item B<check ($value)>
322 This method will return a true (C<1>) if the C<$value> passes the
323 constraint, and false (C<0>) otherwise.
325 =item B<validate ($value)>
327 This method is similar to C<check>, but it deals with the error
328 message. If the C<$value> passes the constraint, C<undef> will be
329 returned. If the C<$value> does B<not> pass the constraint, then
330 the C<message> will be used to construct a custom error message.
334 The name of the type in the global type registry.
338 This type's parent type.
342 Returns true if this type has a parent type.
352 =item B<get_message ($value)>
354 =item B<has_coercion>
358 =item B<hand_optimized_type_constraint>
360 =item B<has_hand_optimized_type_constraint>
362 =item B<create_child_type>
366 =head2 DEPRECATED METHOD
372 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
379 All complex software has bugs lurking in it, and this module is no
380 exception. If you find a bug please either email me, or add the bug
385 Stevan Little E<lt>stevan@iinteractive.comE<gt>
387 =head1 COPYRIGHT AND LICENSE
389 Copyright 2006-2008 by Infinity Interactive, Inc.
391 L<http://www.iinteractive.com>
393 This library is free software; you can redistribute it and/or modify
394 it under the same terms as Perl itself.