fix and test related to breakage in MX:Types and others when we made the TC->equals...
[gitmo/Moose.git] / lib / Moose / Meta / TypeConstraint.pm
CommitLineData
4e036ee4 1
2package Moose::Meta::TypeConstraint;
3
4use strict;
5use warnings;
6use metaclass;
7
ed90007b 8use overload '0+' => sub { refaddr(shift) }, # id an object
9 '""' => sub { shift->name }, # stringify to tc name
b644e331 10 fallback => 1;
900466d6 11
dabed765 12use Scalar::Util qw(blessed refaddr);
9f2230e9 13use Sub::Name qw(subname);
66811d63 14
e606ae5f 15use base qw(Class::MOP::Object);
16
e462f6f3 17our $VERSION = '1.05';
e606ae5f 18$VERSION = eval $VERSION;
d44714be 19our $AUTHORITY = 'cpan:STEVAN';
66811d63 20
3726f905 21__PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
22__PACKAGE__->meta->add_attribute('parent' => (
23 reader => 'parent',
24 predicate => 'has_parent',
25));
baf26cc6 26
27my $null_constraint = sub { 1 };
d67145ed 28__PACKAGE__->meta->add_attribute('constraint' => (
8de73ff1 29 reader => 'constraint',
30 writer => '_set_constraint',
baf26cc6 31 default => sub { $null_constraint }
d67145ed 32));
76d37e5a 33__PACKAGE__->meta->add_attribute('message' => (
34 accessor => 'message',
35 predicate => 'has_message'
36));
a27aa600 37__PACKAGE__->meta->add_attribute('coercion' => (
38 accessor => 'coercion',
39 predicate => 'has_coercion'
40));
70ea9161 41
c8cf9aaa 42__PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
43 init_arg => 'optimized',
44 accessor => 'hand_optimized_type_constraint',
e27dfc11 45 predicate => 'has_hand_optimized_type_constraint',
c8cf9aaa 46));
47
bd72f3c8 48sub parents {
49 my $self;
50 $self->parent;
51}
52
3726f905 53# private accessors
54
55__PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
56 accessor => '_compiled_type_constraint',
57 predicate => '_has_compiled_type_constraint'
58));
22aed3c0 59__PACKAGE__->meta->add_attribute('package_defined_in' => (
60 accessor => '_package_defined_in'
61));
62
e27dfc11 63sub new {
a27aa600 64 my $class = shift;
8534c69a 65 my ($first, @rest) = @_;
66 my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
67 $args{name} = $args{name} ? "$args{name}" : "__ANON__";
70ea9161 68
8534c69a 69 my $self = $class->_new(%args);
3726f905 70 $self->compile_type_constraint()
71 unless $self->_has_compiled_type_constraint;
66811d63 72 return $self;
73}
74
8534c69a 75
76
70ea9161 77sub coerce {
78 my $self = shift;
79
80 my $coercion = $self->coercion;
81
82 unless ($coercion) {
83 require Moose;
84 Moose->throw_error("Cannot coerce without a type coercion");
85 }
86
02679ba4 87 return $_[0] if $self->check($_[0]);
88
70ea9161 89 return $coercion->coerce(@_);
90}
a1257460 91
92sub check {
93 my ($self, @args) = @_;
94 my $constraint_subref = $self->_compiled_type_constraint;
95 return $constraint_subref->(@args) ? 1 : undef;
96}
97
e27dfc11 98sub validate {
76d37e5a 99 my ($self, $value) = @_;
100 if ($self->_compiled_type_constraint->($value)) {
101 return undef;
102 }
103 else {
688fcdda 104 $self->get_message($value);
76d37e5a 105 }
106}
107
c24269b3 108sub assert_valid {
109 my ($self, $value) = @_;
110
111 my $error = $self->validate($value);
112 return 1 if ! defined $error;
113
114 require Moose;
115 Moose->throw_error($error);
116}
117
688fcdda 118sub get_message {
119 my ($self, $value) = @_;
688fcdda 120 if (my $msg = $self->message) {
121 local $_ = $value;
122 return $msg->($value);
123 }
124 else {
d03bd989 125 $value = (defined $value ? overload::StrVal($value) : 'undef');
24a9f75e 126 return "Validation failed for '" . $self->name . "' with value $value";
d03bd989 127 }
688fcdda 128}
129
3726f905 130## type predicates ...
131
d9e17f80 132sub equals {
133 my ( $self, $type_or_name ) = @_;
134
e606ae5f 135 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
dabed765 136
ed90007b 137 return 1 if 0+$self == 0+$other;
dabed765 138
139 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
140 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
141 }
142
143 return unless $self->constraint == $other->constraint;
144
145 if ( $self->has_parent ) {
146 return unless $other->has_parent;
147 return unless $self->parent->equals( $other->parent );
148 } else {
149 return if $other->has_parent;
150 }
d9e17f80 151
05a5763c 152 return;
d9e17f80 153}
154
b26e162e 155sub is_a_type_of {
d9e17f80 156 my ($self, $type_or_name) = @_;
157
e606ae5f 158 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
d9e17f80 159
160 ($self->equals($type) || $self->is_subtype_of($type));
b26e162e 161}
162
cce8198b 163sub is_subtype_of {
d9e17f80 164 my ($self, $type_or_name) = @_;
165
e606ae5f 166 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
d9e17f80 167
cce8198b 168 my $current = $self;
d9e17f80 169
cce8198b 170 while (my $parent = $current->parent) {
d9e17f80 171 return 1 if $parent->equals($type);
cce8198b 172 $current = $parent;
173 }
d9e17f80 174
cce8198b 175 return 0;
176}
177
3726f905 178## compiling the type constraint
179
180sub compile_type_constraint {
181 my $self = shift;
182 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
451c8248 183}
184
3726f905 185## type compilers ...
186
187sub _actually_compile_type_constraint {
188 my $self = shift;
e27dfc11 189
3726f905 190 return $self->_compile_hand_optimized_type_constraint
191 if $self->has_hand_optimized_type_constraint;
e27dfc11 192
3726f905 193 my $check = $self->constraint;
70ea9161 194 unless ( defined $check ) {
195 require Moose;
196 Moose->throw_error( "Could not compile type constraint '"
e27dfc11 197 . $self->name
70ea9161 198 . "' because no constraint check" );
199 }
e27dfc11 200
3726f905 201 return $self->_compile_subtype($check)
202 if $self->has_parent;
e27dfc11 203
3726f905 204 return $self->_compile_type($check);
205}
206
207sub _compile_hand_optimized_type_constraint {
208 my $self = shift;
e27dfc11 209
3726f905 210 my $type_constraint = $self->hand_optimized_type_constraint;
e27dfc11 211
70ea9161 212 unless ( ref $type_constraint ) {
213 require Moose;
214 Carp::confess ("Hand optimized type constraint for " . $self->name . " is not a code reference");
215 Moose->throw_error("Hand optimized type constraint is not a code reference");
216 }
42bc21a4 217
218 return $type_constraint;
3726f905 219}
220
221sub _compile_subtype {
222 my ($self, $check) = @_;
e27dfc11 223
baf26cc6 224 # gather all the parent constraintss in order
3726f905 225 my @parents;
baf26cc6 226 my $optimized_parent;
3726f905 227 foreach my $parent ($self->_collect_all_parents) {
baf26cc6 228 # if a parent is optimized, the optimized constraint already includes
229 # all of its parents tcs, so we can break the loop
3726f905 230 if ($parent->has_hand_optimized_type_constraint) {
baf26cc6 231 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
e27dfc11 232 last;
3726f905 233 }
234 else {
baf26cc6 235 push @parents => $parent->constraint;
3726f905 236 }
237 }
e27dfc11 238
baf26cc6 239 @parents = grep { $_ != $null_constraint } reverse @parents;
240
241 unless ( @parents ) {
242 return $self->_compile_type($check);
243 } elsif( $optimized_parent and @parents == 1 ) {
244 # the case of just one optimized parent is optimized to prevent
245 # looping and the unnecessary localization
b5981f07 246 if ( $check == $null_constraint ) {
247 return $optimized_parent;
248 } else {
9f2230e9 249 return subname($self->name, sub {
b5981f07 250 return undef unless $optimized_parent->($_[0]);
a1257460 251 my (@args) = @_;
252 local $_ = $args[0];
253 $check->(@args);
b5981f07 254 });
255 }
baf26cc6 256 } else {
257 # general case, check all the constraints, from the first parent to ourselves
b5981f07 258 my @checks = @parents;
259 push @checks, $check if $check != $null_constraint;
9f2230e9 260 return subname($self->name => sub {
a1257460 261 my (@args) = @_;
262 local $_ = $args[0];
baf26cc6 263 foreach my $check (@checks) {
a1257460 264 return undef unless $check->(@args);
baf26cc6 265 }
266 return 1;
267 });
268 }
3726f905 269}
270
271sub _compile_type {
272 my ($self, $check) = @_;
baf26cc6 273
274 return $check if $check == $null_constraint; # Item, Any
275
9f2230e9 276 return subname($self->name => sub {
a1257460 277 my (@args) = @_;
278 local $_ = $args[0];
279 $check->(@args);
1b2aea39 280 });
3726f905 281}
282
283## other utils ...
284
285sub _collect_all_parents {
286 my $self = shift;
287 my @parents;
288 my $current = $self->parent;
289 while (defined $current) {
290 push @parents => $current;
291 $current = $current->parent;
292 }
293 return @parents;
294}
295
85a9908f 296sub create_child_type {
9ceb576e 297 my ($self, %opts) = @_;
298 my $class = ref $self;
299 return $class->new(%opts, parent => $self);
300}
301
4e036ee4 3021;
303
304__END__
305
306=pod
307
308=head1 NAME
309
6ba6d68c 310Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
4e036ee4 311
312=head1 DESCRIPTION
313
cfd006f0 314This class represents a single type constraint. Moose's built-in type
76127c77 315constraints, as well as constraints you define, are all stored in a
cfd006f0 316L<Moose::Meta::TypeConstraint::Registry> object as objects of this
317class.
6ba6d68c 318
baf46b9e 319=head1 INHERITANCE
320
321C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
322
4e036ee4 323=head1 METHODS
324
325=over 4
326
cfd006f0 327=item B<< Moose::Meta::TypeConstraint->new(%options) >>
4e036ee4 328
cfd006f0 329This creates a new type constraint based on the provided C<%options>:
4e036ee4 330
cfd006f0 331=over 8
d9e17f80 332
cfd006f0 333=item * name
e606ae5f 334
cfd006f0 335The constraint name. If a name is not provided, it will be set to
336"__ANON__".
b26e162e 337
cfd006f0 338=item * parent
b26e162e 339
cfd006f0 340A C<Moose::Meta::TypeConstraint> object which is the parent type for
341the type being created. This is optional.
cce8198b 342
cfd006f0 343=item * constraint
e606ae5f 344
cfd006f0 345This is the subroutine reference that implements the actual constraint
346check. This defaults to a subroutine which always returns true.
6ba6d68c 347
cfd006f0 348=item * message
0a5bd159 349
cfd006f0 350A subroutine reference which is used to generate an error message when
351the constraint fails. This is optional.
0a5bd159 352
cfd006f0 353=item * coercion
76d37e5a 354
cfd006f0 355A L<Moose::Meta::TypeCoercion> object representing the coercions to
356the type. This is optional.
76d37e5a 357
cfd006f0 358=item * optimized
76d37e5a 359
cfd006f0 360This is a variant of the C<constraint> parameter that is somehow
361optimized. Typically, this means incorporating both the type's
362constraint and all of its parents' constraints into a single
363subroutine reference.
6ba6d68c 364
cfd006f0 365=back
4e036ee4 366
cfd006f0 367=item B<< $constraint->equals($type_name_or_object) >>
e606ae5f 368
cfd006f0 369Returns true if the supplied name or type object is the same as the
370current type.
66811d63 371
cfd006f0 372=item B<< $constraint->is_subtype_of($type_name_or_object) >>
e606ae5f 373
cfd006f0 374Returns true if the supplied name or type object is a parent of the
375current type.
3726f905 376
cfd006f0 377=item B<< $constraint->is_a_type_of($type_name_or_object) >>
e606ae5f 378
cfd006f0 379Returns true if the given type is the same as the current type, or is
380a parent of the current type. This is a shortcut for checking
381C<equals> and C<is_subtype_of>.
d9e17f80 382
cfd006f0 383=item B<< $constraint->coerce($value) >>
2f7e4042 384
cfd006f0 385This will attempt to coerce the value to the type. If the type does
386have any defined coercions this will throw an error.
66811d63 387
cfd006f0 388=item B<< $constraint->check($value) >>
2f7e4042 389
cfd006f0 390Returns true if the given value passes the constraint for the type.
76d37e5a 391
cfd006f0 392=item B<< $constraint->validate($value) >>
2f7e4042 393
cfd006f0 394This is similar to C<check>. However, if the type I<is valid> then the
395method returns an explicit C<undef>. If the type is not valid, we call
396C<< $self->get_message($value) >> internally to generate an error
397message.
76d37e5a 398
952320e0 399=item B<< $constraint->assert_valid($value) >>
400
401Like C<check> and C<validate>, this method checks whether C<$value> is
402valid under the constraint. If it is, it will return true. If it is not,
403an exception will be thrown with the results of
404C<< $self->get_message($value) >>.
405
cfd006f0 406=item B<< $constraint->name >>
2f7e4042 407
cfd006f0 408Returns the type's name, as provided to the constructor.
688fcdda 409
cfd006f0 410=item B<< $constraint->parent >>
2f7e4042 411
cfd006f0 412Returns the type's parent, as provided to the constructor, if any.
4e036ee4 413
cfd006f0 414=item B<< $constraint->has_parent >>
2f7e4042 415
cfd006f0 416Returns true if the type has a parent type.
a27aa600 417
cfd006f0 418=item B<< $constraint->parents >>
2f7e4042 419
cfd006f0 420A synonym for C<parent>. This is useful for polymorphism with types
421that can have more than one parent.
c8cf9aaa 422
cfd006f0 423=item B<< $constraint->constraint >>
c8cf9aaa 424
cfd006f0 425Returns the type's constraint, as provided to the constructor.
9ceb576e 426
cfd006f0 427=item B<< $constraint->get_message($value) >>
4e036ee4 428
cfd006f0 429This generates a method for the given value. If the type does not have
430an explicit message, we generate a default message.
3726f905 431
cfd006f0 432=item B<< $constraint->has_message >>
433
434Returns true if the type has a message.
435
436=item B<< $constraint->message >>
437
438Returns the type's message as a subroutine reference.
439
440=item B<< $constraint->coercion >>
441
442Returns the type's L<Moose::Meta::TypeCoercion> object, if one
443exists.
444
445=item B<< $constraint->has_coercion >>
446
447Returns true if the type has a coercion.
448
449=item B<< $constraint->hand_optimized_type_constraint >>
450
451Returns the type's hand optimized constraint, as provided to the
452constructor via the C<optimized> option.
453
454=item B<< $constraint->has_hand_optimized_type_constraint >>
455
456Returns true if the type has an optimized constraint.
457
458=item B<< $constraint->create_child_type(%options) >>
451c8248 459
cfd006f0 460This returns a new type constraint of the same class using the
461provided C<%options>. The C<parent> option will be the current type.
3726f905 462
cfd006f0 463This method exists so that subclasses of this class can override this
464behavior and change how child types are created.
451c8248 465
466=back
467
4e036ee4 468=head1 BUGS
469
d4048ef3 470See L<Moose/BUGS> for details on reporting bugs.
4e036ee4 471
472=head1 AUTHOR
473
474Stevan Little E<lt>stevan@iinteractive.comE<gt>
475
476=head1 COPYRIGHT AND LICENSE
477
7e0492d3 478Copyright 2006-2010 by Infinity Interactive, Inc.
4e036ee4 479
480L<http://www.iinteractive.com>
481
482This library is free software; you can redistribute it and/or modify
e27dfc11 483it under the same terms as Perl itself.
4e036ee4 484
c8cf9aaa 485=cut