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};
34 if(defined($check) && ref($check) ne 'CODE'){
35 confess("Constraint for $args{name} is not a CODE reference");
38 $args{package_defined_in} ||= caller;
40 my $self = bless \%args, $class;
41 $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
43 if($self->{type_constraints}){ # Union
45 foreach my $type(@{$self->{type_constraints}}){
46 if($type->has_coercion){
47 push @coercions, $type;
51 $self->{_compiled_type_coercion} = sub {
53 foreach my $type(@coercions){
54 my $value = $type->coerce($thing);
55 return $value if $self->check($value);
65 sub create_child_type{
68 return ref($self)->new(
69 # a child inherits its parent's attributes
72 # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
73 compiled_type_constraint => undef,
74 hand_optimized_type_constraint => undef,
76 # and is given child-specific args, of course.
85 sub compile_type_constraint{
90 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
91 if($parent->{hand_optimized_type_constraint}){
92 unshift @checks, $parent->{hand_optimized_type_constraint};
93 last; # a hand optimized constraint must include all the parents
95 elsif($parent->{constraint}){
96 unshift @checks, $parent->{constraint};
101 if($self->{constraint}){
102 push @checks, $self->{constraint};
105 if($self->{type_constraints}){ # Union
106 my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
108 foreach my $c(@types){
109 return 1 if $c->($_[0]);
116 $self->{compiled_type_constraint} = $null_check;
120 $self->{compiled_type_constraint} = sub{
127 $self->{compiled_type_constraint} = sub{
130 foreach my $c(@checks){
131 return undef if !$c->(@args);
139 sub _add_type_coercions{
142 my $coercions = ($self->{_coercion_map} ||= []);
143 my %has = map{ $_->[0] => undef } @{$coercions};
145 for(my $i = 0; $i < @_; $i++){
147 my $action = $_[++$i];
149 if(exists $has{$from}){
150 confess("A coercion action already exists for '$from'");
153 my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
154 or confess("Could not find the type constraint ($from) to coerce from");
156 push @{$coercions}, [ $type => $action ];
160 if(exists $self->{type_constraints}){ # union type
161 confess("Cannot add additional type coercions to Union types");
164 $self->{_compiled_type_coercion} = sub {
166 foreach my $pair (@{$coercions}) {
\r
167 #my ($constraint, $converter) = @$pair;
\r
168 if ($pair->[0]->check($thing)) {
\r
170 return $pair->[1]->($thing);
181 return $self->_compiled_type_constraint->(@_);
186 if(!$self->{_compiled_type_coercion}){
187 confess("Cannot coerce without a type coercion ($self)");
190 return $_[0] if $self->_compiled_type_constraint->(@_);
192 return $self->{_compiled_type_coercion}->(@_);
196 my ($self, $value) = @_;
197 if ( my $msg = $self->message ) {
199 return $msg->($value);
202 $value = ( defined $value ? overload::StrVal($value) : 'undef' );
203 return "Validation failed for '$self' failed with value $value";
208 my($self, $other) = @_;
210 # ->is_a_type_of('__ANON__') is always false
211 return 0 if !blessed($other) && $other eq '__ANON__';
213 (my $other_name = $other) =~ s/\s+//g;
215 return 1 if $self->name eq $other_name;
217 if(exists $self->{type_constraints}){ # union
218 foreach my $type(@{$self->{type_constraints}}){
219 return 1 if $type->name eq $other_name;
223 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
224 return 1 if $parent->name eq $other_name;
236 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
240 This document describes Mouse version 0.40
244 For the most part, the only time you will ever encounter an
245 instance of this class is if you are doing some serious deep
246 introspection. This API should not be considered final, but
247 it is B<highly unlikely> that this will matter to a regular
264 L<Moose::Meta::TypeConstraint>