1 package Mouse::Meta::TypeConstraint;
6 '""' => sub { shift->{name} }, # stringify to tc name
10 use Scalar::Util qw(blessed reftype);
12 use Mouse::Util qw(:meta);
14 my $null_check = sub { 1 };
17 my($class, %args) = @_;
19 $args{name} = '__ANON__' if !defined $args{name};
21 my $check = delete $args{optimized};
23 if($args{_compiled_type_constraint}){
24 Carp::cluck("'_compiled_type_constraint' has been deprecated, use 'optimized' instead");
25 $check = $args{_compiled_type_constraint};
28 Carp::cluck("Constraint must be a CODE reference");
29 $check = $check->{compiled_type_constraint};
34 $args{hand_optimized_type_constraint} = $check;
35 $args{compiled_type_constraint} = $check;
38 $check = $args{constraint};
41 Carp::cluck("Constraint for $args{name} must be a CODE reference");
42 $check = $check->{compiled_type_constraint};
45 if(defined($check) && ref($check) ne 'CODE'){
46 confess("Constraint for $args{name} is not a CODE reference");
49 $args{package_defined_in} ||= caller;
51 my $self = bless \%args, $class;
52 $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
54 if($self->{type_constraints}){ # Union
56 foreach my $type(@{$self->{type_constraints}}){
57 if($type->has_coercion){
58 push @coercions, $type;
62 $self->{_compiled_type_coercion} = sub {
64 foreach my $type(@coercions){
65 my $value = $type->coerce($thing);
66 return $value if $self->check($value);
76 sub create_child_type{
79 return ref($self)->new(
80 # a child inherits its parent's attributes
83 # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
84 compiled_type_constraint => undef,
85 hand_optimized_type_constraint => undef,
87 # and is given child-specific args, of course.
95 sub name { $_[0]->{name} }
96 sub parent { $_[0]->{parent} }
97 sub message { $_[0]->{message} }
99 sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
101 sub has_coercion{ exists $_[0]->{_compiled_type_coercion} }
103 sub compile_type_constraint{
108 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
109 if($parent->{hand_optimized_type_constraint}){
110 push @checks, $parent->{hand_optimized_type_constraint};
111 last; # a hand optimized constraint must include all the parents
113 elsif($parent->{constraint}){
114 push @checks, $parent->{constraint};
119 if($self->{constraint}){
120 push @checks, $self->{constraint};
123 if($self->{type_constraints}){ # Union
124 my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
126 foreach my $c(@types){
127 return 1 if $c->($_[0]);
134 $self->{compiled_type_constraint} = $null_check;
138 $self->{compiled_type_constraint} = sub{
145 $self->{compiled_type_constraint} = sub{
148 foreach my $c(@checks){
149 return undef if !$c->(@args);
157 sub _add_type_coercions{
160 my $coercions = ($self->{_coercion_map} ||= []);
161 my %has = map{ $_->[0] => undef } @{$coercions};
163 for(my $i = 0; $i < @_; $i++){
165 my $action = $_[++$i];
167 if(exists $has{$from}){
168 confess("A coercion action already exists for '$from'");
171 my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
172 or confess("Could not find the type constraint ($from) to coerce from");
174 push @{$coercions}, [ $type => $action ];
178 if(exists $self->{type_constraints}){ # union type
179 confess("Cannot add additional type coercions to Union types");
182 $self->{_compiled_type_coercion} = sub {
184 foreach my $pair (@{$coercions}) {
\r
185 #my ($constraint, $converter) = @$pair;
\r
186 if ($pair->[0]->check($thing)) {
\r
188 return $pair->[1]->($thing);
199 return $self->_compiled_type_constraint->(@_);
204 if(!$self->{_compiled_type_coercion}){
205 confess("Cannot coerce without a type coercion ($self)");
208 return $_[0] if $self->_compiled_type_constraint->(@_);
210 return $self->{_compiled_type_coercion}->(@_);
214 my ($self, $value) = @_;
215 if ( my $msg = $self->message ) {
217 return $msg->($value);
220 $value = ( defined $value ? overload::StrVal($value) : 'undef' );
221 return "Validation failed for '$self' failed with value $value";
226 my($self, $other) = @_;
228 # ->is_a_type_of('__ANON__') is always false
229 return 0 if !blessed($other) && $other eq '__ANON__';
231 (my $other_name = $other) =~ s/\s+//g;
233 return 1 if $self->name eq $other_name;
235 if(exists $self->{type_constraints}){ # union
236 foreach my $type(@{$self->{type_constraints}}){
237 return 1 if $type->name eq $other_name;
241 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
242 return 1 if $parent->name eq $other_name;
254 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
258 For the most part, the only time you will ever encounter an
259 instance of this class is if you are doing some serious deep
260 introspection. This API should not be considered final, but
261 it is B<highly unlikely> that this will matter to a regular
278 L<Moose::Meta::TypeConstraint>