lib/Mouse/Meta/TypeConstraint.pm

   1 package Mouse::Meta::TypeConstraint;
   2 use Mouse::Util qw(:meta); # enables strict and warnings
   3
   4 use overload
   5     '""'     => sub { shift->{name} },   # stringify to tc name
   6     fallback => 1;
   7
   8 use Carp qw(confess);
   9 use Scalar::Util qw(blessed reftype);
  10
  11 my $null_check = sub { 1 };
  12
  13 sub new {
  14     my($class, %args) = @_;
  15
  16     $args{name} = '__ANON__' if !defined $args{name};
  17
  18     my $check = delete $args{optimized};
  19
  20     if($args{_compiled_type_constraint}){
  21         Carp::cluck("'_compiled_type_constraint' has been deprecated, use 'optimized' instead")
  22             if _MOUSE_VERBOSE;
  23
  24         $check = $args{_compiled_type_constraint};
  25     }
  26
  27     if($check){
  28         $args{hand_optimized_type_constraint} = $check;
  29         $args{compiled_type_constraint}       = $check;
  30     }
  31
  32     $check = $args{constraint};
  33
  34     if(blessed($check)){
  35         Carp::cluck("Constraint for $args{name} must be a CODE reference");
  36         $check = $check->{compiled_type_constraint};
  37     }
  38
  39     if(defined($check) && ref($check) ne 'CODE'){
  40         confess("Constraint for $args{name} is not a CODE reference");
  41     }
  42
  43     $args{package_defined_in} ||= caller;
  44
  45     my $self = bless \%args, $class;
  46     $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
  47
  48     if($self->{type_constraints}){ # Union
  49         my @coercions;
  50         foreach my $type(@{$self->{type_constraints}}){
  51             if($type->has_coercion){
  52                 push @coercions, $type;
  53             }
  54         }
  55         if(@coercions){
  56             $self->{_compiled_type_coercion} = sub {
  57                 my($thing) = @_;
  58                 foreach my $type(@coercions){
  59                     my $value = $type->coerce($thing);
  60                     return $value if $self->check($value);
  61                 }
  62                 return $thing;
  63             };
  64         }
  65     }
  66
  67     return $self;
  68 }
  69
  70 sub create_child_type{
  71     my $self = shift;
  72     # XXX: FIXME
  73     return ref($self)->new(
  74         # a child inherits its parent's attributes
  75         %{$self},
  76
  77         # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
  78         compiled_type_constraint       => undef,
  79         hand_optimized_type_constraint => undef,
  80
  81         # and is given child-specific args, of course.
  82         @_,
  83
  84         # and its parent
  85         parent => $self,
  86    );
  87 }
  88
  89
  90 sub compile_type_constraint{
  91     my($self) = @_;
  92
  93     # add parents first
  94     my @checks;
  95     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
  96          if($parent->{hand_optimized_type_constraint}){
  97             unshift @checks, $parent->{hand_optimized_type_constraint};
  98             last; # a hand optimized constraint must include all the parents
  99         }
 100         elsif($parent->{constraint}){
 101             unshift @checks, $parent->{constraint};
 102         }
 103     }
 104
 105     # then add child
 106     if($self->{constraint}){
 107         push @checks, $self->{constraint};
 108     }
 109
 110     if($self->{type_constraints}){ # Union
 111         my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
 112         push @checks, sub{
 113             foreach my $c(@types){
 114                 return 1 if $c->($_[0]);
 115             }
 116             return 0;
 117         };
 118     }
 119
 120     if(@checks == 0){
 121         $self->{compiled_type_constraint} = $null_check;
 122     }
 123     elsif(@checks == 1){
 124         my $c = $checks[0];
 125         $self->{compiled_type_constraint} = sub{
 126             my(@args) = @_;
 127             local $_ = $args[0];
 128             return $c->(@args);
 129         };
 130     }
 131     else{
 132         $self->{compiled_type_constraint} =  sub{
 133             my(@args) = @_;
 134             local $_ = $args[0];
 135             foreach my $c(@checks){
 136                 return undef if !$c->(@args);
 137             }
 138             return 1;
 139         };
 140     }
 141     return;
 142 }
 143
 144 sub _add_type_coercions{
 145     my $self = shift;
 146
 147     my $coercions = ($self->{_coercion_map} ||= []);
 148     my %has       = map{ $_->[0] => undef } @{$coercions};
 149
 150     for(my $i = 0; $i < @_; $i++){
 151         my $from   = $_[  $i];
 152         my $action = $_[++$i];
 153
 154         if(exists $has{$from}){
 155             confess("A coercion action already exists for '$from'");
 156         }
 157
 158         my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
 159             or confess("Could not find the type constraint ($from) to coerce from");
 160
 161         push @{$coercions}, [ $type => $action ];
 162     }
 163
 164     # compile
 165     if(exists $self->{type_constraints}){ # union type
 166         confess("Cannot add additional type coercions to Union types");
 167     }
 168     else{
 169         $self->{_compiled_type_coercion} = sub {
 170            my($thing) = @_;\r
 171            foreach my $pair (@{$coercions}) {\r
 172                 #my ($constraint, $converter) = @$pair;\r
 173                 if ($pair->[0]->check($thing)) {\r
 174                   local $_ = $thing;
 175                   return $pair->[1]->($thing);
 176                 }\r
 177            }\r
 178            return $thing;\r
 179         };
 180     }
 181     return;
 182 }
 183
 184 sub check {
 185     my $self = shift;
 186     return $self->_compiled_type_constraint->(@_);
 187 }
 188
 189 sub coerce {
 190     my $self = shift;
 191     if(!$self->{_compiled_type_coercion}){
 192         confess("Cannot coerce without a type coercion ($self)");
 193     }
 194
 195     return $_[0] if $self->_compiled_type_constraint->(@_);
 196
 197     return $self->{_compiled_type_coercion}->(@_);
 198 }
 199
 200 sub get_message {
 201     my ($self, $value) = @_;
 202     if ( my $msg = $self->message ) {
 203         local $_ = $value;
 204         return $msg->($value);
 205     }
 206     else {
 207         $value = ( defined $value ? overload::StrVal($value) : 'undef' );
 208         return "Validation failed for '$self' failed with value $value";
 209     }
 210 }
 211
 212 sub is_a_type_of{
 213     my($self, $other) = @_;
 214
 215     # ->is_a_type_of('__ANON__') is always false
 216     return 0 if !blessed($other) && $other eq '__ANON__';
 217
 218     (my $other_name = $other) =~ s/\s+//g;
 219
 220     return 1 if $self->name eq $other_name;
 221
 222     if(exists $self->{type_constraints}){ # union
 223         foreach my $type(@{$self->{type_constraints}}){
 224             return 1 if $type->name eq $other_name;
 225         }
 226     }
 227
 228     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 229         return 1 if $parent->name eq $other_name;
 230     }
 231
 232     return 0;
 233 }
 234
 235
 236 1;
 237 __END__
 238
 239 =head1 NAME
 240
 241 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
 242
 243 =head1 VERSION
 244
 245 This document describes Mouse version 0.40
 246
 247 =head1 DESCRIPTION
 248
 249 For the most part, the only time you will ever encounter an
 250 instance of this class is if you are doing some serious deep
 251 introspection. This API should not be considered final, but
 252 it is B<highly unlikely> that this will matter to a regular
 253 Mouse user.
 254
 255 Don't use this.
 256
 257 =head1 METHODS
 258
 259 =over 4
 260
 261 =item B<new>
 262
 263 =item B<name>
 264
 265 =back
 266
 267 =head1 SEE ALSO
 268
 269 L<Moose::Meta::TypeConstraint>
 270
 271 =cut
 272