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.
89 sub name { $_[0]->{name} }
90 sub parent { $_[0]->{parent} }
91 sub message { $_[0]->{message} }
93 sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
95 sub has_coercion{ exists $_[0]->{_compiled_type_coercion} }
97 sub compile_type_constraint{
102 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
103 if($parent->{hand_optimized_type_constraint}){
104 push @checks, $parent->{hand_optimized_type_constraint};
105 last; # a hand optimized constraint must include all the parents
107 elsif($parent->{constraint}){
108 push @checks, $parent->{constraint};
113 if($self->{constraint}){
114 push @checks, $self->{constraint};
117 if($self->{type_constraints}){ # Union
118 my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
120 foreach my $c(@types){
121 return 1 if $c->($_[0]);
128 $self->{compiled_type_constraint} = $null_check;
132 $self->{compiled_type_constraint} = sub{
139 $self->{compiled_type_constraint} = sub{
142 foreach my $c(@checks){
143 return undef if !$c->(@args);
151 sub _add_type_coercions{
154 my $coercions = ($self->{_coercion_map} ||= []);
155 my %has = map{ $_->[0] => undef } @{$coercions};
157 for(my $i = 0; $i < @_; $i++){
159 my $action = $_[++$i];
161 if(exists $has{$from}){
162 confess("A coercion action already exists for '$from'");
165 my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
166 or confess("Could not find the type constraint ($from) to coerce from");
168 push @{$coercions}, [ $type => $action ];
172 if(exists $self->{type_constraints}){ # union type
173 confess("Cannot add additional type coercions to Union types");
176 $self->{_compiled_type_coercion} = sub {
178 foreach my $pair (@{$coercions}) {
\r
179 #my ($constraint, $converter) = @$pair;
\r
180 if ($pair->[0]->check($thing)) {
\r
182 return $pair->[1]->($thing);
193 return $self->_compiled_type_constraint->(@_);
198 if(!$self->{_compiled_type_coercion}){
199 confess("Cannot coerce without a type coercion ($self)");
202 return $_[0] if $self->_compiled_type_constraint->(@_);
204 return $self->{_compiled_type_coercion}->(@_);
208 my ($self, $value) = @_;
209 if ( my $msg = $self->message ) {
211 return $msg->($value);
214 $value = ( defined $value ? overload::StrVal($value) : 'undef' );
215 return "Validation failed for '$self' failed with value $value";
220 my($self, $other) = @_;
222 # ->is_a_type_of('__ANON__') is always false
223 return 0 if !blessed($other) && $other eq '__ANON__';
225 (my $other_name = $other) =~ s/\s+//g;
227 return 1 if $self->name eq $other_name;
229 if(exists $self->{type_constraints}){ # union
230 foreach my $type(@{$self->{type_constraints}}){
231 return 1 if $type->name eq $other_name;
235 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
236 return 1 if $parent->name eq $other_name;
248 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
252 This document describes Mouse version 0.39
256 For the most part, the only time you will ever encounter an
257 instance of this class is if you are doing some serious deep
258 introspection. This API should not be considered final, but
259 it is B<highly unlikely> that this will matter to a regular
276 L<Moose::Meta::TypeConstraint>