2 package Moose::Meta::TypeConstraint;
8 use overload '0+' => sub { refaddr(shift) }, # id an object
9 '""' => sub { shift->name }, # stringify to tc name
14 use Class::Load qw(load_class);
16 use Scalar::Util qw(blessed refaddr);
17 use Sub::Name qw(subname);
20 use base qw(Class::MOP::Object);
22 __PACKAGE__->meta->add_attribute('name' => (
24 Class::MOP::_definition_context(),
26 __PACKAGE__->meta->add_attribute('parent' => (
28 predicate => 'has_parent',
29 Class::MOP::_definition_context(),
32 my $null_constraint = sub { 1 };
33 __PACKAGE__->meta->add_attribute('constraint' => (
34 reader => 'constraint',
35 writer => '_set_constraint',
36 default => sub { $null_constraint },
37 Class::MOP::_definition_context(),
40 __PACKAGE__->meta->add_attribute('message' => (
41 accessor => 'message',
42 predicate => 'has_message',
43 Class::MOP::_definition_context(),
46 __PACKAGE__->meta->add_attribute('_default_message' => (
47 accessor => '_default_message',
48 Class::MOP::_definition_context(),
51 # can't make this a default because it has to close over the type name, and
52 # cmop attributes don't have lazy
53 my $_default_message_generator = sub {
57 # have to load it late like this, since it uses Moose itself
58 my $can_partialdump = try {
59 # versions prior to 0.14 had a potential infinite loop bug
60 load_class('Devel::PartialDump', { -version => 0.14 });
63 if ($can_partialdump) {
64 $value = Devel::PartialDump->new->dump($value);
67 $value = (defined $value ? overload::StrVal($value) : 'undef');
69 return "Validation failed for '" . $name . "' with value $value";
72 __PACKAGE__->meta->add_attribute('coercion' => (
73 accessor => 'coercion',
74 predicate => 'has_coercion',
75 Class::MOP::_definition_context(),
78 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
79 init_arg => 'optimized',
80 accessor => 'hand_optimized_type_constraint',
81 predicate => 'has_hand_optimized_type_constraint',
82 Class::MOP::_definition_context(),
85 __PACKAGE__->meta->add_attribute('inlined' => (
86 init_arg => 'inlined',
87 accessor => 'inlined',
88 predicate => '_has_inlined_type_constraint',
89 Class::MOP::_definition_context(),
92 __PACKAGE__->meta->add_attribute('inline_environment' => (
93 init_arg => 'inline_environment',
94 accessor => '_inline_environment',
95 default => sub { {} },
96 Class::MOP::_definition_context(),
106 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
107 accessor => '_compiled_type_constraint',
108 predicate => '_has_compiled_type_constraint',
109 Class::MOP::_definition_context(),
112 __PACKAGE__->meta->add_attribute('package_defined_in' => (
113 accessor => '_package_defined_in',
114 Class::MOP::_definition_context(),
119 my ($first, @rest) = @_;
120 my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
121 $args{name} = $args{name} ? "$args{name}" : "__ANON__";
123 if ( $args{optimized} ) {
124 Moose::Deprecated::deprecated(
125 feature => 'optimized type constraint sub ref',
127 'Providing an optimized subroutine ref for type constraints is deprecated.'
128 . ' Use the inlining feature (inline_as) instead.'
132 if ( exists $args{message}
133 && (!ref($args{message}) || ref($args{message}) ne 'CODE') ) {
134 confess("The 'message' parameter must be a coderef");
137 my $self = $class->_new(%args);
138 $self->compile_type_constraint()
139 unless $self->_has_compiled_type_constraint;
140 $self->_default_message($_default_message_generator->($self->name))
141 unless $self->has_message;
150 my $coercion = $self->coercion;
154 Moose->throw_error("Cannot coerce without a type coercion");
157 return $_[0] if $self->check($_[0]);
159 return $coercion->coerce(@_);
165 my $coercion = $self->coercion;
169 Moose->throw_error("Cannot coerce without a type coercion");
172 return $_[0] if $self->check($_[0]);
174 my $result = $coercion->coerce(@_);
176 $self->assert_valid($result);
182 my ($self, @args) = @_;
183 my $constraint_subref = $self->_compiled_type_constraint;
184 return $constraint_subref->(@args) ? 1 : undef;
188 my ($self, $value) = @_;
189 if ($self->_compiled_type_constraint->($value)) {
193 $self->get_message($value);
200 if ( $self->has_parent && $self->constraint == $null_constraint ) {
201 return $self->parent->can_be_inlined;
204 return $self->_has_inlined_type_constraint;
210 unless ( $self->can_be_inlined ) {
212 Moose->throw_error( 'Cannot inline a type constraint check for ' . $self->name );
215 if ( $self->has_parent && $self->constraint == $null_constraint ) {
216 return $self->parent->_inline_check(@_);
219 return '( do { ' . $self->inlined->( $self, @_ ) . ' } )';
222 sub inline_environment {
225 if ( $self->has_parent && $self->constraint == $null_constraint ) {
226 return $self->parent->inline_environment;
229 return $self->_inline_environment;
233 my ($self, $value) = @_;
235 my $error = $self->validate($value);
236 return 1 if ! defined $error;
239 Moose->throw_error($error);
243 my ($self, $value) = @_;
244 my $msg = $self->has_message
246 : $self->_default_message;
248 return $msg->($value);
251 ## type predicates ...
254 my ( $self, $type_or_name ) = @_;
256 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
258 return 1 if $self == $other;
260 if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
261 return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
264 return unless $self->constraint == $other->constraint;
266 if ( $self->has_parent ) {
267 return unless $other->has_parent;
268 return unless $self->parent->equals( $other->parent );
270 return if $other->has_parent;
277 my ($self, $type_or_name) = @_;
279 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
281 ($self->equals($type) || $self->is_subtype_of($type));
285 my ($self, $type_or_name) = @_;
287 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
291 while (my $parent = $current->parent) {
292 return 1 if $parent->equals($type);
299 ## compiling the type constraint
301 sub compile_type_constraint {
303 $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
306 ## type compilers ...
308 sub _actually_compile_type_constraint {
311 return $self->_compile_hand_optimized_type_constraint
312 if $self->has_hand_optimized_type_constraint;
314 if ( $self->can_be_inlined ) {
316 source => 'sub { ' . $self->_inline_check('$_[0]') . ' }',
317 environment => $self->inline_environment,
321 my $check = $self->constraint;
322 unless ( defined $check ) {
324 Moose->throw_error( "Could not compile type constraint '"
326 . "' because no constraint check" );
329 return $self->_compile_subtype($check)
330 if $self->has_parent;
332 return $self->_compile_type($check);
335 sub _compile_hand_optimized_type_constraint {
338 my $type_constraint = $self->hand_optimized_type_constraint;
340 unless ( ref $type_constraint ) {
342 Moose->throw_error("Hand optimized type constraint is not a code reference");
345 return $type_constraint;
348 sub _compile_subtype {
349 my ($self, $check) = @_;
351 # gather all the parent constraintss in order
353 my $optimized_parent;
354 foreach my $parent ($self->_collect_all_parents) {
355 # if a parent is optimized, the optimized constraint already includes
356 # all of its parents tcs, so we can break the loop
357 if ($parent->has_hand_optimized_type_constraint) {
358 push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
362 push @parents => $parent->constraint;
366 @parents = grep { $_ != $null_constraint } reverse @parents;
368 unless ( @parents ) {
369 return $self->_compile_type($check);
370 } elsif( $optimized_parent and @parents == 1 ) {
371 # the case of just one optimized parent is optimized to prevent
372 # looping and the unnecessary localization
373 if ( $check == $null_constraint ) {
374 return $optimized_parent;
376 return subname($self->name, sub {
377 return undef unless $optimized_parent->($_[0]);
384 # general case, check all the constraints, from the first parent to ourselves
385 my @checks = @parents;
386 push @checks, $check if $check != $null_constraint;
387 return subname($self->name => sub {
390 foreach my $check (@checks) {
391 return undef unless $check->(@args);
399 my ($self, $check) = @_;
401 return $check if $check == $null_constraint; # Item, Any
403 return subname($self->name => sub {
412 sub _collect_all_parents {
415 my $current = $self->parent;
416 while (defined $current) {
417 push @parents => $current;
418 $current = $current->parent;
423 sub _ancestor_count {
425 return scalar $self->_collect_all_parents;
428 sub create_child_type {
429 my ($self, %opts) = @_;
430 my $class = ref $self;
431 return $class->new(%opts, parent => $self);
436 # ABSTRACT: The Moose Type Constraint metaclass
444 This class represents a single type constraint. Moose's built-in type
445 constraints, as well as constraints you define, are all stored in a
446 L<Moose::Meta::TypeConstraint::Registry> object as objects of this
451 C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
457 =item B<< Moose::Meta::TypeConstraint->new(%options) >>
459 This creates a new type constraint based on the provided C<%options>:
465 The constraint name. If a name is not provided, it will be set to
470 A C<Moose::Meta::TypeConstraint> object which is the parent type for
471 the type being created. This is optional.
475 This is the subroutine reference that implements the actual constraint
476 check. This defaults to a subroutine which always returns true.
480 A subroutine reference which is used to generate an error message when
481 the constraint fails. This is optional.
485 A L<Moose::Meta::TypeCoercion> object representing the coercions to
486 the type. This is optional.
490 A subroutine which returns a string suitable for inlining this type
491 constraint. It will be called as a method on the type constraint object, and
492 will receive a single additional parameter, a variable name to be tested
493 (usually C<"$_"> or C<"$_[0]">.
497 =item * inline_environment
499 A hash reference of variables to close over. The keys are variables names, and
500 the values are I<references> to the variables.
504 B<This option is deprecated.>
506 This is a variant of the C<constraint> parameter that is somehow
507 optimized. Typically, this means incorporating both the type's
508 constraint and all of its parents' constraints into a single
509 subroutine reference.
513 =item B<< $constraint->equals($type_name_or_object) >>
515 Returns true if the supplied name or type object is the same as the
518 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
520 Returns true if the supplied name or type object is a parent of the
523 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
525 Returns true if the given type is the same as the current type, or is
526 a parent of the current type. This is a shortcut for checking
527 C<equals> and C<is_subtype_of>.
529 =item B<< $constraint->coerce($value) >>
531 This will attempt to coerce the value to the type. If the type does not
532 have any defined coercions this will throw an error.
534 If no coercion can produce a value matching C<$constraint>, the original
537 =item B<< $constraint->assert_coerce($value) >>
539 This method behaves just like C<coerce>, but if the result is not valid
540 according to C<$constraint>, an error is thrown.
542 =item B<< $constraint->check($value) >>
544 Returns true if the given value passes the constraint for the type.
546 =item B<< $constraint->validate($value) >>
548 This is similar to C<check>. However, if the type I<is valid> then the
549 method returns an explicit C<undef>. If the type is not valid, we call
550 C<< $self->get_message($value) >> internally to generate an error
553 =item B<< $constraint->assert_valid($value) >>
555 Like C<check> and C<validate>, this method checks whether C<$value> is
556 valid under the constraint. If it is, it will return true. If it is not,
557 an exception will be thrown with the results of
558 C<< $self->get_message($value) >>.
560 =item B<< $constraint->name >>
562 Returns the type's name, as provided to the constructor.
564 =item B<< $constraint->parent >>
566 Returns the type's parent, as provided to the constructor, if any.
568 =item B<< $constraint->has_parent >>
570 Returns true if the type has a parent type.
572 =item B<< $constraint->parents >>
574 A synonym for C<parent>. This is useful for polymorphism with types
575 that can have more than one parent.
577 =item B<< $constraint->constraint >>
579 Returns the type's constraint, as provided to the constructor.
581 =item B<< $constraint->get_message($value) >>
583 This generates a method for the given value. If the type does not have
584 an explicit message, we generate a default message.
586 =item B<< $constraint->has_message >>
588 Returns true if the type has a message.
590 =item B<< $constraint->message >>
592 Returns the type's message as a subroutine reference.
594 =item B<< $constraint->coercion >>
596 Returns the type's L<Moose::Meta::TypeCoercion> object, if one
599 =item B<< $constraint->has_coercion >>
601 Returns true if the type has a coercion.
603 =item B<< $constraint->can_be_inlined >>
605 Returns true if this type constraint can be inlined. A type constraint which
606 subtypes an inlinable constraint and does not add an additional constraint
607 "inherits" its parent type's inlining.
609 =item B<< $constraint->hand_optimized_type_constraint >>
611 B<This method is deprecated.>
613 Returns the type's hand optimized constraint, as provided to the
614 constructor via the C<optimized> option.
616 =item B<< $constraint->has_hand_optimized_type_constraint >>
618 B<This method is deprecated.>
620 Returns true if the type has an optimized constraint.
622 =item B<< $constraint->create_child_type(%options) >>
624 This returns a new type constraint of the same class using the
625 provided C<%options>. The C<parent> option will be the current type.
627 This method exists so that subclasses of this class can override this
628 behavior and change how child types are created.
634 See L<Moose/BUGS> for details on reporting bugs.