2 package Moose::Meta::TypeConstraint;
8 use overload '""' => sub { shift->name }, # stringify to tc name
11 use Sub::Name 'subname';
13 use Scalar::Util qw(blessed refaddr);
15 our $VERSION = '0.12';
16 our $AUTHORITY = 'cpan:STEVAN';
18 __PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
19 __PACKAGE__->meta->add_attribute('parent' => (
21 predicate => 'has_parent',
23 __PACKAGE__->meta->add_attribute('constraint' => (
24 reader => 'constraint',
25 writer => '_set_constraint',
26 default => sub { sub { 1 } }
28 __PACKAGE__->meta->add_attribute('message' => (
29 accessor => 'message',
30 predicate => 'has_message'
32 __PACKAGE__->meta->add_attribute('coercion' => (
33 accessor => 'coercion',
34 predicate => 'has_coercion'
36 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
37 init_arg => 'optimized',
38 accessor => 'hand_optimized_type_constraint',
39 predicate => 'has_hand_optimized_type_constraint',
49 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
50 accessor => '_compiled_type_constraint',
51 predicate => '_has_compiled_type_constraint'
53 __PACKAGE__->meta->add_attribute('package_defined_in' => (
54 accessor => '_package_defined_in'
59 my $self = $class->meta->new_object(@_);
60 $self->compile_type_constraint()
61 unless $self->_has_compiled_type_constraint;
65 sub coerce { ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_) }
66 sub check { $_[0]->_compiled_type_constraint->($_[1]) ? 1 : undef }
68 my ($self, $value) = @_;
69 if ($self->_compiled_type_constraint->($value)) {
73 $self->get_message($value);
78 my ($self, $value) = @_;
79 $value = (defined $value ? overload::StrVal($value) : 'undef');
80 if (my $msg = $self->message) {
82 return $msg->($value);
85 return "Validation failed for '" . $self->name . "' failed with value $value";
89 ## type predicates ...
92 my ( $self, $type_or_name ) = @_;
94 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
96 return 1 if refaddr($self) == refaddr($other);
98 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
99 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
102 return unless $self->constraint == $other->constraint;
104 if ( $self->has_parent ) {
105 return unless $other->has_parent;
106 return unless $self->parent->equals( $other->parent );
108 return if $other->has_parent;
115 my ($self, $type_or_name) = @_;
117 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
119 ($self->equals($type) || $self->is_subtype_of($type));
123 my ($self, $type_or_name) = @_;
125 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
129 while (my $parent = $current->parent) {
130 return 1 if $parent->equals($type);
137 ## compiling the type constraint
139 sub compile_type_constraint {
141 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
144 ## type compilers ...
146 sub _actually_compile_type_constraint {
149 return $self->_compile_hand_optimized_type_constraint
150 if $self->has_hand_optimized_type_constraint;
152 my $check = $self->constraint;
154 || confess "Could not compile type constraint '"
156 . "' because no constraint check";
158 return $self->_compile_subtype($check)
159 if $self->has_parent;
161 return $self->_compile_type($check);
164 sub _compile_hand_optimized_type_constraint {
167 my $type_constraint = $self->hand_optimized_type_constraint;
169 confess unless ref $type_constraint;
171 return $type_constraint;
174 sub _compile_subtype {
175 my ($self, $check) = @_;
177 # so we gather all the parents in order
178 # and grab their constraints ...
180 foreach my $parent ($self->_collect_all_parents) {
181 if ($parent->has_hand_optimized_type_constraint) {
182 unshift @parents => $parent->hand_optimized_type_constraint;
186 unshift @parents => $parent->constraint;
190 # then we compile them to run without
191 # having to recurse as we did before
192 return subname $self->name => sub {
194 foreach my $parent (@parents) {
195 return undef unless $parent->($_[0]);
197 return undef unless $check->($_[0]);
203 my ($self, $check) = @_;
204 return subname $self->name => sub {
206 return undef unless $check->($_[0]);
213 sub _collect_all_parents {
216 my $current = $self->parent;
217 while (defined $current) {
218 push @parents => $current;
219 $current = $current->parent;
224 ## this should get deprecated actually ...
226 sub union { Carp::croak "DEPRECATED" }
236 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
240 For the most part, the only time you will ever encounter an
241 instance of this class is if you are doing some serious deep
242 introspection. This API should not be considered final, but
243 it is B<highly unlikely> that this will matter to a regular
246 If you wish to use features at this depth, please come to the
247 #moose IRC channel on irc.perl.org and we can talk :)
257 =item B<equals ($type_name_or_object)>
259 =item B<is_a_type_of ($type_name_or_object)>
261 This checks the current type name, and if it does not match,
262 checks if it is a subtype of it.
264 =item B<is_subtype_of ($type_name_or_object)>
266 =item B<compile_type_constraint>
268 =item B<coerce ($value)>
270 This will apply the type-coercion if applicable.
272 =item B<check ($value)>
274 This method will return a true (C<1>) if the C<$value> passes the
275 constraint, and false (C<0>) otherwise.
277 =item B<validate ($value)>
279 This method is similar to C<check>, but it deals with the error
280 message. If the C<$value> passes the constraint, C<undef> will be
281 returned. If the C<$value> does B<not> pass the constraint, then
282 the C<message> will be used to construct a custom error message.
298 =item B<get_message ($value)>
300 =item B<has_coercion>
304 =item B<hand_optimized_type_constraint>
306 =item B<has_hand_optimized_type_constraint>
310 =head2 DEPRECATED METHOD
316 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
323 All complex software has bugs lurking in it, and this module is no
324 exception. If you find a bug please either email me, or add the bug
329 Stevan Little E<lt>stevan@iinteractive.comE<gt>
331 =head1 COPYRIGHT AND LICENSE
333 Copyright 2006-2008 by Infinity Interactive, Inc.
335 L<http://www.iinteractive.com>
337 This library is free software; you can redistribute it and/or modify
338 it under the same terms as Perl itself.