1 package Mouse::Meta::TypeConstraint;
2 use Mouse::Util qw(:meta); # enables strict and warnings
5 '""' => sub { $_[0]->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->(@_);
187 return $_[0] if $self->_compiled_type_constraint->(@_);
189 my $coercion = $self->_compiled_type_coercion;
190 return $coercion ? $coercion->(@_) : $_[0];
194 my ($self, $value) = @_;
195 if ( my $msg = $self->message ) {
197 return $msg->($value);
200 $value = ( defined $value ? overload::StrVal($value) : 'undef' );
201 return "Validation failed for '$self' failed with value $value";
206 my($self, $other) = @_;
208 # ->is_a_type_of('__ANON__') is always false
209 return 0 if !blessed($other) && $other eq '__ANON__';
211 (my $other_name = $other) =~ s/\s+//g;
213 return 1 if $self->name eq $other_name;
215 if(exists $self->{type_constraints}){ # union
216 foreach my $type(@{$self->{type_constraints}}){
217 return 1 if $type->name eq $other_name;
221 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
222 return 1 if $parent->name eq $other_name;
234 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
238 This document describes Mouse version 0.40_01
242 For the most part, the only time you will ever encounter an
243 instance of this class is if you are doing some serious deep
244 introspection. This API should not be considered final, but
245 it is B<highly unlikely> that this will matter to a regular
262 L<Moose::Meta::TypeConstraint>