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