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 sub name    { $_[0]->{name}    }
  90 sub parent  { $_[0]->{parent}  }
  91 sub message { $_[0]->{message} }
  92
  93 sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
  94
  95 sub has_coercion{ exists $_[0]->{_compiled_type_coercion} }
  96
  97 sub compile_type_constraint{
  98     my($self) = @_;
  99
 100     # add parents first
 101     my @checks;
 102     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 103          if($parent->{hand_optimized_type_constraint}){
 104             unshift @checks, $parent->{hand_optimized_type_constraint};
 105             last; # a hand optimized constraint must include all the parents
 106         }
 107         elsif($parent->{constraint}){
 108             unshift @checks, $parent->{constraint};
 109         }
 110     }
 111
 112     # then add child
 113     if($self->{constraint}){
 114         push @checks, $self->{constraint};
 115     }
 116
 117     if($self->{type_constraints}){ # Union
 118         my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
 119         push @checks, sub{
 120             foreach my $c(@types){
 121                 return 1 if $c->($_[0]);
 122             }
 123             return 0;
 124         };
 125     }
 126
 127     if(@checks == 0){
 128         $self->{compiled_type_constraint} = $null_check;
 129     }
 130     elsif(@checks == 1){
 131         my $c = $checks[0];
 132         $self->{compiled_type_constraint} = sub{
 133             my(@args) = @_;
 134             local $_ = $args[0];
 135             return $c->(@args);
 136         };
 137     }
 138     else{
 139         $self->{compiled_type_constraint} =  sub{
 140             my(@args) = @_;
 141             local $_ = $args[0];
 142             foreach my $c(@checks){
 143                 return undef if !$c->(@args);
 144             }
 145             return 1;
 146         };
 147     }
 148     return;
 149 }
 150
 151 sub _add_type_coercions{
 152     my $self = shift;
 153
 154     my $coercions = ($self->{_coercion_map} ||= []);
 155     my %has       = map{ $_->[0] => undef } @{$coercions};
 156
 157     for(my $i = 0; $i < @_; $i++){
 158         my $from   = $_[  $i];
 159         my $action = $_[++$i];
 160
 161         if(exists $has{$from}){
 162             confess("A coercion action already exists for '$from'");
 163         }
 164
 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");
 167
 168         push @{$coercions}, [ $type => $action ];
 169     }
 170
 171     # compile
 172     if(exists $self->{type_constraints}){ # union type
 173         confess("Cannot add additional type coercions to Union types");
 174     }
 175     else{
 176         $self->{_compiled_type_coercion} = sub {
 177            my($thing) = @_;\r
 178            foreach my $pair (@{$coercions}) {\r
 179                 #my ($constraint, $converter) = @$pair;\r
 180                 if ($pair->[0]->check($thing)) {\r
 181                   local $_ = $thing;
 182                   return $pair->[1]->($thing);
 183                 }\r
 184            }\r
 185            return $thing;\r
 186         };
 187     }
 188     return;
 189 }
 190
 191 sub check {
 192     my $self = shift;
 193     return $self->_compiled_type_constraint->(@_);
 194 }
 195
 196 sub coerce {
 197     my $self = shift;
 198     if(!$self->{_compiled_type_coercion}){
 199         confess("Cannot coerce without a type coercion ($self)");
 200     }
 201
 202     return $_[0] if $self->_compiled_type_constraint->(@_);
 203
 204     return $self->{_compiled_type_coercion}->(@_);
 205 }
 206
 207 sub get_message {
 208     my ($self, $value) = @_;
 209     if ( my $msg = $self->message ) {
 210         local $_ = $value;
 211         return $msg->($value);
 212     }
 213     else {
 214         $value = ( defined $value ? overload::StrVal($value) : 'undef' );
 215         return "Validation failed for '$self' failed with value $value";
 216     }
 217 }
 218
 219 sub is_a_type_of{
 220     my($self, $other) = @_;
 221
 222     # ->is_a_type_of('__ANON__') is always false
 223     return 0 if !blessed($other) && $other eq '__ANON__';
 224
 225     (my $other_name = $other) =~ s/\s+//g;
 226
 227     return 1 if $self->name eq $other_name;
 228
 229     if(exists $self->{type_constraints}){ # union
 230         foreach my $type(@{$self->{type_constraints}}){
 231             return 1 if $type->name eq $other_name;
 232         }
 233     }
 234
 235     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 236         return 1 if $parent->name eq $other_name;
 237     }
 238
 239     return 0;
 240 }
 241
 242
 243 1;
 244 __END__
 245
 246 =head1 NAME
 247
 248 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
 249
 250 =head1 VERSION
 251
 252 This document describes Mouse version 0.39
 253
 254 =head1 DESCRIPTION
 255
 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
 260 Mouse user.
 261
 262 Don't use this.
 263
 264 =head1 METHODS
 265
 266 =over 4
 267
 268 =item B<new>
 269
 270 =item B<name>
 271
 272 =back
 273
 274 =head1 SEE ALSO
 275
 276 L<Moose::Meta::TypeConstraint>
 277
 278 =cut
 279