Implement the "eval $VERSION" trick from perlmodstyle so CPAN doesn't
[gitmo/Moose.git] / lib / Moose / Meta / TypeConstraint.pm
CommitLineData
4e036ee4 1
2package Moose::Meta::TypeConstraint;
3
4use strict;
5use warnings;
6use metaclass;
7
b644e331 8use overload '""' => sub { shift->name }, # stringify to tc name
9 fallback => 1;
900466d6 10
c07af9d2 11use Carp 'confess';
dabed765 12use Scalar::Util qw(blessed refaddr);
66811d63 13
0779da92 14use base qw(Class::MOP::Object);
15
75b95414 16our $VERSION = '0.55_01';
17$VERSION = eval $VERSION;
d44714be 18our $AUTHORITY = 'cpan:STEVAN';
66811d63 19
3726f905 20__PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
21__PACKAGE__->meta->add_attribute('parent' => (
22 reader => 'parent',
23 predicate => 'has_parent',
24));
baf26cc6 25
26my $null_constraint = sub { 1 };
d67145ed 27__PACKAGE__->meta->add_attribute('constraint' => (
8de73ff1 28 reader => 'constraint',
29 writer => '_set_constraint',
baf26cc6 30 default => sub { $null_constraint }
d67145ed 31));
76d37e5a 32__PACKAGE__->meta->add_attribute('message' => (
33 accessor => 'message',
34 predicate => 'has_message'
35));
a27aa600 36__PACKAGE__->meta->add_attribute('coercion' => (
37 accessor => 'coercion',
38 predicate => 'has_coercion'
39));
c8cf9aaa 40__PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
41 init_arg => 'optimized',
42 accessor => 'hand_optimized_type_constraint',
e27dfc11 43 predicate => 'has_hand_optimized_type_constraint',
c8cf9aaa 44));
45
bd72f3c8 46sub parents {
47 my $self;
48 $self->parent;
49}
50
3726f905 51# private accessors
52
53__PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
54 accessor => '_compiled_type_constraint',
55 predicate => '_has_compiled_type_constraint'
56));
22aed3c0 57__PACKAGE__->meta->add_attribute('package_defined_in' => (
58 accessor => '_package_defined_in'
59));
60
e27dfc11 61sub new {
a27aa600 62 my $class = shift;
0779da92 63 my $self = $class->_new(@_);
3726f905 64 $self->compile_type_constraint()
65 unless $self->_has_compiled_type_constraint;
66811d63 66 return $self;
67}
68
3726f905 69sub coerce { ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_) }
42bc21a4 70sub check { $_[0]->_compiled_type_constraint->($_[1]) ? 1 : undef }
e27dfc11 71sub validate {
76d37e5a 72 my ($self, $value) = @_;
73 if ($self->_compiled_type_constraint->($value)) {
74 return undef;
75 }
76 else {
688fcdda 77 $self->get_message($value);
76d37e5a 78 }
79}
80
688fcdda 81sub get_message {
82 my ($self, $value) = @_;
688fcdda 83 if (my $msg = $self->message) {
84 local $_ = $value;
85 return $msg->($value);
86 }
87 else {
d5598ade 88 $value = (defined $value ? overload::StrVal($value) : 'undef');
688fcdda 89 return "Validation failed for '" . $self->name . "' failed with value $value";
90 }
91}
92
3726f905 93## type predicates ...
94
d9e17f80 95sub equals {
96 my ( $self, $type_or_name ) = @_;
97
dabed765 98 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
99
100 return 1 if refaddr($self) == refaddr($other);
101
102 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
103 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
104 }
105
106 return unless $self->constraint == $other->constraint;
107
108 if ( $self->has_parent ) {
109 return unless $other->has_parent;
110 return unless $self->parent->equals( $other->parent );
111 } else {
112 return if $other->has_parent;
113 }
d9e17f80 114
dabed765 115 return 1;
d9e17f80 116}
117
b26e162e 118sub is_a_type_of {
d9e17f80 119 my ($self, $type_or_name) = @_;
120
121 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
122
123 ($self->equals($type) || $self->is_subtype_of($type));
b26e162e 124}
125
cce8198b 126sub is_subtype_of {
d9e17f80 127 my ($self, $type_or_name) = @_;
128
129 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
130
cce8198b 131 my $current = $self;
d9e17f80 132
cce8198b 133 while (my $parent = $current->parent) {
d9e17f80 134 return 1 if $parent->equals($type);
cce8198b 135 $current = $parent;
136 }
d9e17f80 137
cce8198b 138 return 0;
139}
140
3726f905 141## compiling the type constraint
142
143sub compile_type_constraint {
144 my $self = shift;
145 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
451c8248 146}
147
3726f905 148## type compilers ...
149
150sub _actually_compile_type_constraint {
151 my $self = shift;
e27dfc11 152
3726f905 153 return $self->_compile_hand_optimized_type_constraint
154 if $self->has_hand_optimized_type_constraint;
e27dfc11 155
3726f905 156 my $check = $self->constraint;
157 (defined $check)
e27dfc11 158 || confess "Could not compile type constraint '"
159 . $self->name
3726f905 160 . "' because no constraint check";
e27dfc11 161
3726f905 162 return $self->_compile_subtype($check)
163 if $self->has_parent;
e27dfc11 164
3726f905 165 return $self->_compile_type($check);
166}
167
168sub _compile_hand_optimized_type_constraint {
169 my $self = shift;
e27dfc11 170
3726f905 171 my $type_constraint = $self->hand_optimized_type_constraint;
e27dfc11 172
42bc21a4 173 confess unless ref $type_constraint;
174
175 return $type_constraint;
3726f905 176}
177
178sub _compile_subtype {
179 my ($self, $check) = @_;
e27dfc11 180
baf26cc6 181 # gather all the parent constraintss in order
3726f905 182 my @parents;
baf26cc6 183 my $optimized_parent;
3726f905 184 foreach my $parent ($self->_collect_all_parents) {
baf26cc6 185 # if a parent is optimized, the optimized constraint already includes
186 # all of its parents tcs, so we can break the loop
3726f905 187 if ($parent->has_hand_optimized_type_constraint) {
baf26cc6 188 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
e27dfc11 189 last;
3726f905 190 }
191 else {
baf26cc6 192 push @parents => $parent->constraint;
3726f905 193 }
194 }
e27dfc11 195
baf26cc6 196 @parents = grep { $_ != $null_constraint } reverse @parents;
197
198 unless ( @parents ) {
199 return $self->_compile_type($check);
200 } elsif( $optimized_parent and @parents == 1 ) {
201 # the case of just one optimized parent is optimized to prevent
202 # looping and the unnecessary localization
b5981f07 203 if ( $check == $null_constraint ) {
204 return $optimized_parent;
205 } else {
206 return Class::MOP::subname($self->name, sub {
207 return undef unless $optimized_parent->($_[0]);
208 local $_ = $_[0];
209 $check->($_[0]);
210 });
211 }
baf26cc6 212 } else {
213 # general case, check all the constraints, from the first parent to ourselves
b5981f07 214 my @checks = @parents;
215 push @checks, $check if $check != $null_constraint;
baf26cc6 216 return Class::MOP::subname($self->name => sub {
217 local $_ = $_[0];
218 foreach my $check (@checks) {
219 return undef unless $check->($_[0]);
220 }
221 return 1;
222 });
223 }
3726f905 224}
225
226sub _compile_type {
227 my ($self, $check) = @_;
baf26cc6 228
229 return $check if $check == $null_constraint; # Item, Any
230
1b2aea39 231 return Class::MOP::subname($self->name => sub {
6f9ff1af 232 local $_ = $_[0];
baf26cc6 233 $check->($_[0]);
1b2aea39 234 });
3726f905 235}
236
237## other utils ...
238
239sub _collect_all_parents {
240 my $self = shift;
241 my @parents;
242 my $current = $self->parent;
243 while (defined $current) {
244 push @parents => $current;
245 $current = $current->parent;
246 }
247 return @parents;
248}
249
250## this should get deprecated actually ...
251
547dda77 252sub union { Carp::croak "DEPRECATED" }
3726f905 253
4e036ee4 2541;
255
256__END__
257
258=pod
259
260=head1 NAME
261
6ba6d68c 262Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
4e036ee4 263
264=head1 DESCRIPTION
265
e27dfc11 266For the most part, the only time you will ever encounter an
267instance of this class is if you are doing some serious deep
268introspection. This API should not be considered final, but
269it is B<highly unlikely> that this will matter to a regular
6ba6d68c 270Moose user.
271
e27dfc11 272If you wish to use features at this depth, please come to the
6ba6d68c 273#moose IRC channel on irc.perl.org and we can talk :)
274
4e036ee4 275=head1 METHODS
276
277=over 4
278
279=item B<meta>
280
281=item B<new>
282
d9e17f80 283=item B<equals ($type_name_or_object)>
284
285=item B<is_a_type_of ($type_name_or_object)>
b26e162e 286
e27dfc11 287This checks the current type name, and if it does not match,
b26e162e 288checks if it is a subtype of it.
289
d9e17f80 290=item B<is_subtype_of ($type_name_or_object)>
cce8198b 291
6ba6d68c 292=item B<compile_type_constraint>
293
0a5bd159 294=item B<coerce ($value)>
295
296This will apply the type-coercion if applicable.
297
76d37e5a 298=item B<check ($value)>
299
e27dfc11 300This method will return a true (C<1>) if the C<$value> passes the
76d37e5a 301constraint, and false (C<0>) otherwise.
302
303=item B<validate ($value)>
304
e27dfc11 305This method is similar to C<check>, but it deals with the error
306message. If the C<$value> passes the constraint, C<undef> will be
307returned. If the C<$value> does B<not> pass the constraint, then
308the C<message> will be used to construct a custom error message.
6ba6d68c 309
4e036ee4 310=item B<name>
311
66811d63 312=item B<parent>
313
3726f905 314=item B<has_parent>
315
d9e17f80 316=item B<parents>
317
66811d63 318=item B<constraint>
319
76d37e5a 320=item B<has_message>
321
322=item B<message>
323
688fcdda 324=item B<get_message ($value)>
325
4e036ee4 326=item B<has_coercion>
327
a27aa600 328=item B<coercion>
329
c8cf9aaa 330=item B<hand_optimized_type_constraint>
331
332=item B<has_hand_optimized_type_constraint>
333
4e036ee4 334=back
335
3726f905 336=head2 DEPRECATED METHOD
337
451c8248 338=over 4
339
3726f905 340=item B<union>
341
342This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
343itself instead.
451c8248 344
345=back
346
4e036ee4 347=head1 BUGS
348
e27dfc11 349All complex software has bugs lurking in it, and this module is no
4e036ee4 350exception. If you find a bug please either email me, or add the bug
351to cpan-RT.
352
353=head1 AUTHOR
354
355Stevan Little E<lt>stevan@iinteractive.comE<gt>
356
357=head1 COPYRIGHT AND LICENSE
358
778db3ac 359Copyright 2006-2008 by Infinity Interactive, Inc.
4e036ee4 360
361L<http://www.iinteractive.com>
362
363This library is free software; you can redistribute it and/or modify
e27dfc11 364it under the same terms as Perl itself.
4e036ee4 365
c8cf9aaa 366=cut