1 package Mouse::Meta::TypeConstraint;
2 use Mouse::Util qw(:meta); # enables strict and warnings
5 '""' => sub { $_[0]->name }, # stringify to tc name
7 '|' => sub { # or-combination
8 require Mouse::Util::TypeConstraints;
9 return Mouse::Util::TypeConstraints::find_or_parse_type_constraint(
18 my $null_check = sub { 1 };
21 my($class, %args) = @_;
23 $args{name} = '__ANON__' if !defined $args{name};
25 my $check = delete $args{optimized};
27 if($args{_compiled_type_constraint}){
28 Carp::cluck("'_compiled_type_constraint' has been deprecated, use 'optimized' instead")
31 $check = $args{_compiled_type_constraint};
35 $args{hand_optimized_type_constraint} = $check;
36 $args{compiled_type_constraint} = $check;
39 $check = $args{constraint};
41 if(defined($check) && ref($check) ne 'CODE'){
42 Carp::confess("Constraint for $args{name} is not a CODE reference");
45 $args{package_defined_in} ||= caller;
47 my $self = bless \%args, $class;
48 $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
50 if($self->{type_constraints}){ # Union
52 foreach my $type(@{$self->{type_constraints}}){
53 if($type->has_coercion){
54 push @coercions, $type;
58 $self->{_compiled_type_coercion} = sub {
60 foreach my $type(@coercions){
61 my $value = $type->coerce($thing);
62 return $value if $self->check($value);
72 sub create_child_type{
75 return ref($self)->new(
76 # a child inherits its parent's attributes
79 # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
80 compiled_type_constraint => undef,
81 hand_optimized_type_constraint => undef,
83 # and is given child-specific args, of course.
92 sub compile_type_constraint{
97 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
98 if($parent->{hand_optimized_type_constraint}){
99 unshift @checks, $parent->{hand_optimized_type_constraint};
100 last; # a hand optimized constraint must include all the parents
102 elsif($parent->{constraint}){
103 unshift @checks, $parent->{constraint};
108 if($self->{constraint}){
109 push @checks, $self->{constraint};
112 if($self->{type_constraints}){ # Union
113 my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
115 foreach my $c(@types){
116 return 1 if $c->($_[0]);
123 $self->{compiled_type_constraint} = $null_check;
127 $self->{compiled_type_constraint} = sub{
134 $self->{compiled_type_constraint} = sub{
137 foreach my $c(@checks){
138 return undef if !$c->(@args);
146 sub _add_type_coercions{
149 my $coercions = ($self->{_coercion_map} ||= []);
150 my %has = map{ $_->[0] => undef } @{$coercions};
152 for(my $i = 0; $i < @_; $i++){
154 my $action = $_[++$i];
156 if(exists $has{$from}){
157 Carp::confess("A coercion action already exists for '$from'");
160 my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
161 or Carp::confess("Could not find the type constraint ($from) to coerce from");
163 push @{$coercions}, [ $type => $action ];
167 if(exists $self->{type_constraints}){ # union type
168 Carp::confess("Cannot add additional type coercions to Union types");
171 $self->{_compiled_type_coercion} = sub {
173 foreach my $pair (@{$coercions}) {
\r
174 #my ($constraint, $converter) = @$pair;
\r
175 if ($pair->[0]->check($thing)) {
\r
177 return $pair->[1]->($thing);
188 return $self->_compiled_type_constraint->(@_);
194 return $_[0] if $self->_compiled_type_constraint->(@_);
196 my $coercion = $self->_compiled_type_coercion;
197 return $coercion ? $coercion->(@_) : $_[0];
201 my ($self, $value) = @_;
202 if ( my $msg = $self->message ) {
204 return $msg->($value);
207 $value = ( defined $value ? overload::StrVal($value) : 'undef' );
208 return "Validation failed for '$self' failed with value $value";
213 my($self, $other) = @_;
215 # ->is_a_type_of('__ANON__') is always false
216 return 0 if !ref($other) && $other eq '__ANON__';
218 (my $other_name = $other) =~ s/\s+//g;
220 return 1 if $self->name eq $other_name;
222 if(exists $self->{type_constraints}){ # union
223 foreach my $type(@{$self->{type_constraints}}){
224 return 1 if $type->name eq $other_name;
228 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
229 return 1 if $parent->name eq $other_name;
241 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
245 This document describes Mouse version 0.40_02
249 For the most part, the only time you will ever encounter an
250 instance of this class is if you are doing some serious deep
251 introspection. This API should not be considered final, but
252 it is B<highly unlikely> that this will matter to a regular
269 L<Moose::Meta::TypeConstraint>