2 package Moose::Meta::TypeConstraint;
8 use overload '""' => sub { shift->name }, # stringify to tc name
11 use Sub::Name 'subname';
13 use Scalar::Util 'blessed';
15 our $VERSION = '0.11';
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',
44 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
45 accessor => '_compiled_type_constraint',
46 predicate => '_has_compiled_type_constraint'
48 __PACKAGE__->meta->add_attribute('package_defined_in' => (
49 accessor => '_package_defined_in'
54 my $self = $class->meta->new_object(@_);
55 $self->compile_type_constraint()
56 unless $self->_has_compiled_type_constraint;
60 sub coerce { ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_) }
61 sub check { $_[0]->_compiled_type_constraint->($_[1]) ? 1 : undef }
63 my ($self, $value) = @_;
64 if ($self->_compiled_type_constraint->($value)) {
68 $self->get_message($value);
73 my ($self, $value) = @_;
74 $value = (defined $value ? overload::StrVal($value) : 'undef');
75 if (my $msg = $self->message) {
77 return $msg->($value);
80 return "Validation failed for '" . $self->name . "' failed with value $value";
84 ## type predicates ...
87 my ($self, $type_name) = @_;
88 ($self->name eq $type_name || $self->is_subtype_of($type_name));
92 my ($self, $type_name) = @_;
94 while (my $parent = $current->parent) {
95 return 1 if $parent->name eq $type_name;
101 ## compiling the type constraint
103 sub compile_type_constraint {
105 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
108 ## type compilers ...
110 sub _actually_compile_type_constraint {
113 return $self->_compile_hand_optimized_type_constraint
114 if $self->has_hand_optimized_type_constraint;
116 my $check = $self->constraint;
118 || confess "Could not compile type constraint '"
120 . "' because no constraint check";
122 return $self->_compile_subtype($check)
123 if $self->has_parent;
125 return $self->_compile_type($check);
128 sub _compile_hand_optimized_type_constraint {
131 my $type_constraint = $self->hand_optimized_type_constraint;
133 confess unless ref $type_constraint;
135 return $type_constraint;
138 sub _compile_subtype {
139 my ($self, $check) = @_;
141 # so we gather all the parents in order
142 # and grab their constraints ...
144 foreach my $parent ($self->_collect_all_parents) {
145 if ($parent->has_hand_optimized_type_constraint) {
146 unshift @parents => $parent->hand_optimized_type_constraint;
150 unshift @parents => $parent->constraint;
154 # then we compile them to run without
155 # having to recurse as we did before
156 return subname $self->name => sub {
158 foreach my $parent (@parents) {
159 return undef unless $parent->($_[0]);
161 return undef unless $check->($_[0]);
167 my ($self, $check) = @_;
168 return subname $self->name => sub {
170 return undef unless $check->($_[0]);
177 sub _collect_all_parents {
180 my $current = $self->parent;
181 while (defined $current) {
182 push @parents => $current;
183 $current = $current->parent;
188 ## this should get deprecated actually ...
190 sub union { die "DEPRECATED" }
200 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
204 For the most part, the only time you will ever encounter an
205 instance of this class is if you are doing some serious deep
206 introspection. This API should not be considered final, but
207 it is B<highly unlikely> that this will matter to a regular
210 If you wish to use features at this depth, please come to the
211 #moose IRC channel on irc.perl.org and we can talk :)
221 =item B<is_a_type_of ($type_name)>
223 This checks the current type name, and if it does not match,
224 checks if it is a subtype of it.
226 =item B<is_subtype_of ($type_name)>
228 =item B<compile_type_constraint>
230 =item B<coerce ($value)>
232 This will apply the type-coercion if applicable.
234 =item B<check ($value)>
236 This method will return a true (C<1>) if the C<$value> passes the
237 constraint, and false (C<0>) otherwise.
239 =item B<validate ($value)>
241 This method is similar to C<check>, but it deals with the error
242 message. If the C<$value> passes the constraint, C<undef> will be
243 returned. If the C<$value> does B<not> pass the constraint, then
244 the C<message> will be used to construct a custom error message.
258 =item B<get_message ($value)>
260 =item B<has_coercion>
264 =item B<hand_optimized_type_constraint>
266 =item B<has_hand_optimized_type_constraint>
270 =head2 DEPRECATED METHOD
276 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
283 All complex software has bugs lurking in it, and this module is no
284 exception. If you find a bug please either email me, or add the bug
289 Stevan Little E<lt>stevan@iinteractive.comE<gt>
291 =head1 COPYRIGHT AND LICENSE
293 Copyright 2006-2008 by Infinity Interactive, Inc.
295 L<http://www.iinteractive.com>
297 This library is free software; you can redistribute it and/or modify
298 it under the same terms as Perl itself.