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 { $_[0]->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
 187     return $_[0] if $self->_compiled_type_constraint->(@_);
 188
 189     my $coercion = $self->_compiled_type_coercion;
 190     return $coercion ? $coercion->(@_) : $_[0];
 191 }
 192
 193 sub get_message {
 194     my ($self, $value) = @_;
 195     if ( my $msg = $self->message ) {
 196         local $_ = $value;
 197         return $msg->($value);
 198     }
 199     else {
 200         $value = ( defined $value ? overload::StrVal($value) : 'undef' );
 201         return "Validation failed for '$self' failed with value $value";
 202     }
 203 }
 204
 205 sub is_a_type_of{
 206     my($self, $other) = @_;
 207
 208     # ->is_a_type_of('__ANON__') is always false
 209     return 0 if !blessed($other) && $other eq '__ANON__';
 210
 211     (my $other_name = $other) =~ s/\s+//g;
 212
 213     return 1 if $self->name eq $other_name;
 214
 215     if(exists $self->{type_constraints}){ # union
 216         foreach my $type(@{$self->{type_constraints}}){
 217             return 1 if $type->name eq $other_name;
 218         }
 219     }
 220
 221     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 222         return 1 if $parent->name eq $other_name;
 223     }
 224
 225     return 0;
 226 }
 227
 228
 229 1;
 230 __END__
 231
 232 =head1 NAME
 233
 234 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
 235
 236 =head1 VERSION
 237
 238 This document describes Mouse version 0.40
 239
 240 =head1 DESCRIPTION
 241
 242 For the most part, the only time you will ever encounter an
 243 instance of this class is if you are doing some serious deep
 244 introspection. This API should not be considered final, but
 245 it is B<highly unlikely> that this will matter to a regular
 246 Mouse user.
 247
 248 Don't use this.
 249
 250 =head1 METHODS
 251
 252 =over 4
 253
 254 =item B<new>
 255
 256 =item B<name>
 257
 258 =back
 259
 260 =head1 SEE ALSO
 261
 262 L<Moose::Meta::TypeConstraint>
 263
 264 =cut
 265