1 package Mouse::Meta::TypeConstraint;
2 use Mouse::Util qw(:meta); # enables strict and warnings
5 '""' => sub { shift->{name} }, # stringify to tc name
9 use Scalar::Util qw(blessed reftype);
11 my $null_check = sub { 1 };
14 my($class, %args) = @_;
16 $args{name} = '__ANON__' if !defined $args{name};
18 my $check = delete $args{optimized};
20 if($args{_compiled_type_constraint}){
21 Carp::cluck("'_compiled_type_constraint' has been deprecated, use 'optimized' instead")
24 $check = $args{_compiled_type_constraint};
28 $args{hand_optimized_type_constraint} = $check;
29 $args{compiled_type_constraint} = $check;
32 $check = $args{constraint};
35 Carp::cluck("Constraint for $args{name} must be a CODE reference");
36 $check = $check->{compiled_type_constraint};
39 if(defined($check) && ref($check) ne 'CODE'){
40 confess("Constraint for $args{name} is not a CODE reference");
43 $args{package_defined_in} ||= caller;
45 my $self = bless \%args, $class;
46 $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
48 if($self->{type_constraints}){ # Union
50 foreach my $type(@{$self->{type_constraints}}){
51 if($type->has_coercion){
52 push @coercions, $type;
56 $self->{_compiled_type_coercion} = sub {
58 foreach my $type(@coercions){
59 my $value = $type->coerce($thing);
60 return $value if $self->check($value);
70 sub create_child_type{
73 return ref($self)->new(
74 # a child inherits its parent's attributes
77 # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
78 compiled_type_constraint => undef,
79 hand_optimized_type_constraint => undef,
81 # and is given child-specific args, of course.
90 sub compile_type_constraint{
95 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
96 if($parent->{hand_optimized_type_constraint}){
97 unshift @checks, $parent->{hand_optimized_type_constraint};
98 last; # a hand optimized constraint must include all the parents
100 elsif($parent->{constraint}){
101 unshift @checks, $parent->{constraint};
106 if($self->{constraint}){
107 push @checks, $self->{constraint};
110 if($self->{type_constraints}){ # Union
111 my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
113 foreach my $c(@types){
114 return 1 if $c->($_[0]);
121 $self->{compiled_type_constraint} = $null_check;
125 $self->{compiled_type_constraint} = sub{
132 $self->{compiled_type_constraint} = sub{
135 foreach my $c(@checks){
136 return undef if !$c->(@args);
144 sub _add_type_coercions{
147 my $coercions = ($self->{_coercion_map} ||= []);
148 my %has = map{ $_->[0] => undef } @{$coercions};
150 for(my $i = 0; $i < @_; $i++){
152 my $action = $_[++$i];
154 if(exists $has{$from}){
155 confess("A coercion action already exists for '$from'");
158 my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
159 or confess("Could not find the type constraint ($from) to coerce from");
161 push @{$coercions}, [ $type => $action ];
165 if(exists $self->{type_constraints}){ # union type
166 confess("Cannot add additional type coercions to Union types");
169 $self->{_compiled_type_coercion} = sub {
171 foreach my $pair (@{$coercions}) {
\r
172 #my ($constraint, $converter) = @$pair;
\r
173 if ($pair->[0]->check($thing)) {
\r
175 return $pair->[1]->($thing);
186 return $self->_compiled_type_constraint->(@_);
191 if(!$self->{_compiled_type_coercion}){
192 confess("Cannot coerce without a type coercion ($self)");
195 return $_[0] if $self->_compiled_type_constraint->(@_);
197 return $self->{_compiled_type_coercion}->(@_);
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 !blessed($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
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>