1 package Mouse::Meta::TypeConstraint;
2 use Mouse::Util qw(:meta); # enables strict and warnings
5 '""' => sub { $_[0]->name }, # stringify to tc name
10 my $null_check = sub { 1 };
13 my($class, %args) = @_;
15 $args{name} = '__ANON__' if !defined $args{name};
17 my $check = delete $args{optimized};
19 if($args{_compiled_type_constraint}){
20 Carp::cluck("'_compiled_type_constraint' has been deprecated, use 'optimized' instead")
23 $check = $args{_compiled_type_constraint};
27 $args{hand_optimized_type_constraint} = $check;
28 $args{compiled_type_constraint} = $check;
31 $check = $args{constraint};
33 if(defined($check) && ref($check) ne 'CODE'){
34 Carp::confess("Constraint for $args{name} is not a CODE reference");
37 $args{package_defined_in} ||= caller;
39 my $self = bless \%args, $class;
40 $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
42 if($self->{type_constraints}){ # Union
44 foreach my $type(@{$self->{type_constraints}}){
45 if($type->has_coercion){
46 push @coercions, $type;
50 $self->{_compiled_type_coercion} = sub {
52 foreach my $type(@coercions){
53 my $value = $type->coerce($thing);
54 return $value if $self->check($value);
64 sub create_child_type{
67 return ref($self)->new(
68 # a child inherits its parent's attributes
71 # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
72 compiled_type_constraint => undef,
73 hand_optimized_type_constraint => undef,
75 # and is given child-specific args, of course.
84 sub compile_type_constraint{
89 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
90 if($parent->{hand_optimized_type_constraint}){
91 unshift @checks, $parent->{hand_optimized_type_constraint};
92 last; # a hand optimized constraint must include all the parents
94 elsif($parent->{constraint}){
95 unshift @checks, $parent->{constraint};
100 if($self->{constraint}){
101 push @checks, $self->{constraint};
104 if($self->{type_constraints}){ # Union
105 my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
107 foreach my $c(@types){
108 return 1 if $c->($_[0]);
115 $self->{compiled_type_constraint} = $null_check;
119 $self->{compiled_type_constraint} = sub{
126 $self->{compiled_type_constraint} = sub{
129 foreach my $c(@checks){
130 return undef if !$c->(@args);
138 sub _add_type_coercions{
141 my $coercions = ($self->{_coercion_map} ||= []);
142 my %has = map{ $_->[0] => undef } @{$coercions};
144 for(my $i = 0; $i < @_; $i++){
146 my $action = $_[++$i];
148 if(exists $has{$from}){
149 Carp::confess("A coercion action already exists for '$from'");
152 my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
153 or Carp::confess("Could not find the type constraint ($from) to coerce from");
155 push @{$coercions}, [ $type => $action ];
159 if(exists $self->{type_constraints}){ # union type
160 Carp::confess("Cannot add additional type coercions to Union types");
163 $self->{_compiled_type_coercion} = sub {
165 foreach my $pair (@{$coercions}) {
\r
166 #my ($constraint, $converter) = @$pair;
\r
167 if ($pair->[0]->check($thing)) {
\r
169 return $pair->[1]->($thing);
180 return $self->_compiled_type_constraint->(@_);
186 return $_[0] if $self->_compiled_type_constraint->(@_);
188 my $coercion = $self->_compiled_type_coercion;
189 return $coercion ? $coercion->(@_) : $_[0];
193 my ($self, $value) = @_;
194 if ( my $msg = $self->message ) {
196 return $msg->($value);
199 $value = ( defined $value ? overload::StrVal($value) : 'undef' );
200 return "Validation failed for '$self' failed with value $value";
205 my($self, $other) = @_;
207 # ->is_a_type_of('__ANON__') is always false
208 return 0 if !ref($other) && $other eq '__ANON__';
210 (my $other_name = $other) =~ s/\s+//g;
212 return 1 if $self->name eq $other_name;
214 if(exists $self->{type_constraints}){ # union
215 foreach my $type(@{$self->{type_constraints}}){
216 return 1 if $type->name eq $other_name;
220 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
221 return 1 if $parent->name eq $other_name;
233 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
237 This document describes Mouse version 0.40_02
241 For the most part, the only time you will ever encounter an
242 instance of this class is if you are doing some serious deep
243 introspection. This API should not be considered final, but
244 it is B<highly unlikely> that this will matter to a regular
261 L<Moose::Meta::TypeConstraint>