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");
22 $check = $args{_compiled_type_constraint};
25 Carp::cluck("Constraint must be a CODE reference");
26 $check = $check->{compiled_type_constraint};
31 $args{hand_optimized_type_constraint} = $check;
32 $args{compiled_type_constraint} = $check;
35 $check = $args{constraint};
38 Carp::cluck("Constraint for $args{name} must be a CODE reference");
39 $check = $check->{compiled_type_constraint};
42 if(defined($check) && ref($check) ne 'CODE'){
43 confess("Constraint for $args{name} is not a CODE reference");
46 $args{package_defined_in} ||= caller;
48 my $self = bless \%args, $class;
49 $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
51 if($self->{type_constraints}){ # Union
53 foreach my $type(@{$self->{type_constraints}}){
54 if($type->has_coercion){
55 push @coercions, $type;
59 $self->{_compiled_type_coercion} = sub {
61 foreach my $type(@coercions){
62 my $value = $type->coerce($thing);
63 return $value if $self->check($value);
73 sub create_child_type{
76 return ref($self)->new(
77 # a child inherits its parent's attributes
80 # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
81 compiled_type_constraint => undef,
82 hand_optimized_type_constraint => undef,
84 # and is given child-specific args, of course.
92 sub name { $_[0]->{name} }
93 sub parent { $_[0]->{parent} }
94 sub message { $_[0]->{message} }
96 sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
98 sub has_coercion{ exists $_[0]->{_compiled_type_coercion} }
100 sub compile_type_constraint{
105 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
106 if($parent->{hand_optimized_type_constraint}){
107 push @checks, $parent->{hand_optimized_type_constraint};
108 last; # a hand optimized constraint must include all the parents
110 elsif($parent->{constraint}){
111 push @checks, $parent->{constraint};
116 if($self->{constraint}){
117 push @checks, $self->{constraint};
120 if($self->{type_constraints}){ # Union
121 my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
123 foreach my $c(@types){
124 return 1 if $c->($_[0]);
131 $self->{compiled_type_constraint} = $null_check;
135 $self->{compiled_type_constraint} = sub{
142 $self->{compiled_type_constraint} = sub{
145 foreach my $c(@checks){
146 return undef if !$c->(@args);
154 sub _add_type_coercions{
157 my $coercions = ($self->{_coercion_map} ||= []);
158 my %has = map{ $_->[0] => undef } @{$coercions};
160 for(my $i = 0; $i < @_; $i++){
162 my $action = $_[++$i];
164 if(exists $has{$from}){
165 confess("A coercion action already exists for '$from'");
168 my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
169 or confess("Could not find the type constraint ($from) to coerce from");
171 push @{$coercions}, [ $type => $action ];
175 if(exists $self->{type_constraints}){ # union type
176 confess("Cannot add additional type coercions to Union types");
179 $self->{_compiled_type_coercion} = sub {
181 foreach my $pair (@{$coercions}) {
\r
182 #my ($constraint, $converter) = @$pair;
\r
183 if ($pair->[0]->check($thing)) {
\r
185 return $pair->[1]->($thing);
196 return $self->_compiled_type_constraint->(@_);
201 if(!$self->{_compiled_type_coercion}){
202 confess("Cannot coerce without a type coercion ($self)");
205 return $_[0] if $self->_compiled_type_constraint->(@_);
207 return $self->{_compiled_type_coercion}->(@_);
211 my ($self, $value) = @_;
212 if ( my $msg = $self->message ) {
214 return $msg->($value);
217 $value = ( defined $value ? overload::StrVal($value) : 'undef' );
218 return "Validation failed for '$self' failed with value $value";
223 my($self, $other) = @_;
225 # ->is_a_type_of('__ANON__') is always false
226 return 0 if !blessed($other) && $other eq '__ANON__';
228 (my $other_name = $other) =~ s/\s+//g;
230 return 1 if $self->name eq $other_name;
232 if(exists $self->{type_constraints}){ # union
233 foreach my $type(@{$self->{type_constraints}}){
234 return 1 if $type->name eq $other_name;
238 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
239 return 1 if $parent->name eq $other_name;
251 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
255 For the most part, the only time you will ever encounter an
256 instance of this class is if you are doing some serious deep
257 introspection. This API should not be considered final, but
258 it is B<highly unlikely> that this will matter to a regular
275 L<Moose::Meta::TypeConstraint>