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
   7     '|'      => sub {                  # or-combination
   8         require Mouse::Util::TypeConstraints;
   9         return Mouse::Util::TypeConstraints::find_or_parse_type_constraint(
  10             "$_[0] | $_[1]",
  11         );
  12     },
  13
  14     fallback => 1;
  15
  16 use Carp         ();
  17
  18 my $null_check = sub { 1 };
  19
  20 sub new {
  21     my($class, %args) = @_;
  22
  23     $args{name} = '__ANON__' if !defined $args{name};
  24
  25     my $check = delete $args{optimized};
  26
  27     if($args{_compiled_type_constraint}){
  28         Carp::cluck("'_compiled_type_constraint' has been deprecated, use 'optimized' instead")
  29             if _MOUSE_VERBOSE;
  30
  31         $check = $args{_compiled_type_constraint};
  32     }
  33
  34     if($check){
  35         $args{hand_optimized_type_constraint} = $check;
  36         $args{compiled_type_constraint}       = $check;
  37     }
  38
  39     $check = $args{constraint};
  40
  41     if(defined($check) && ref($check) ne 'CODE'){
  42         Carp::confess("Constraint for $args{name} is not a CODE reference");
  43     }
  44
  45     $args{package_defined_in} ||= caller;
  46
  47     my $self = bless \%args, $class;
  48     $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
  49
  50     if($self->{type_constraints}){ # Union
  51         my @coercions;
  52         foreach my $type(@{$self->{type_constraints}}){
  53             if($type->has_coercion){
  54                 push @coercions, $type;
  55             }
  56         }
  57         if(@coercions){
  58             $self->{_compiled_type_coercion} = sub {
  59                 my($thing) = @_;
  60                 foreach my $type(@coercions){
  61                     my $value = $type->coerce($thing);
  62                     return $value if $self->check($value);
  63                 }
  64                 return $thing;
  65             };
  66         }
  67     }
  68
  69     return $self;
  70 }
  71
  72 sub create_child_type{
  73     my $self = shift;
  74     # XXX: FIXME
  75     return ref($self)->new(
  76         # a child inherits its parent's attributes
  77         %{$self},
  78
  79         # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
  80         compiled_type_constraint       => undef,
  81         hand_optimized_type_constraint => undef,
  82
  83         # and is given child-specific args, of course.
  84         @_,
  85
  86         # and its parent
  87         parent => $self,
  88    );
  89 }
  90
  91
  92 sub compile_type_constraint{
  93     my($self) = @_;
  94
  95     # add parents first
  96     my @checks;
  97     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
  98          if($parent->{hand_optimized_type_constraint}){
  99             unshift @checks, $parent->{hand_optimized_type_constraint};
 100             last; # a hand optimized constraint must include all the parents
 101         }
 102         elsif($parent->{constraint}){
 103             unshift @checks, $parent->{constraint};
 104         }
 105     }
 106
 107     # then add child
 108     if($self->{constraint}){
 109         push @checks, $self->{constraint};
 110     }
 111
 112     if($self->{type_constraints}){ # Union
 113         my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
 114         push @checks, sub{
 115             foreach my $c(@types){
 116                 return 1 if $c->($_[0]);
 117             }
 118             return 0;
 119         };
 120     }
 121
 122     if(@checks == 0){
 123         $self->{compiled_type_constraint} = $null_check;
 124     }
 125     elsif(@checks == 1){
 126         my $c = $checks[0];
 127         $self->{compiled_type_constraint} = sub{
 128             my(@args) = @_;
 129             local $_ = $args[0];
 130             return $c->(@args);
 131         };
 132     }
 133     else{
 134         $self->{compiled_type_constraint} =  sub{
 135             my(@args) = @_;
 136             local $_ = $args[0];
 137             foreach my $c(@checks){
 138                 return undef if !$c->(@args);
 139             }
 140             return 1;
 141         };
 142     }
 143     return;
 144 }
 145
 146 sub _add_type_coercions{
 147     my $self = shift;
 148
 149     my $coercions = ($self->{_coercion_map} ||= []);
 150     my %has       = map{ $_->[0] => undef } @{$coercions};
 151
 152     for(my $i = 0; $i < @_; $i++){
 153         my $from   = $_[  $i];
 154         my $action = $_[++$i];
 155
 156         if(exists $has{$from}){
 157             Carp::confess("A coercion action already exists for '$from'");
 158         }
 159
 160         my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
 161             or Carp::confess("Could not find the type constraint ($from) to coerce from");
 162
 163         push @{$coercions}, [ $type => $action ];
 164     }
 165
 166     # compile
 167     if(exists $self->{type_constraints}){ # union type
 168         Carp::confess("Cannot add additional type coercions to Union types");
 169     }
 170     else{
 171         $self->{_compiled_type_coercion} = sub {
 172            my($thing) = @_;\r
 173            foreach my $pair (@{$coercions}) {\r
 174                 #my ($constraint, $converter) = @$pair;\r
 175                 if ($pair->[0]->check($thing)) {\r
 176                   local $_ = $thing;
 177                   return $pair->[1]->($thing);
 178                 }\r
 179            }\r
 180            return $thing;\r
 181         };
 182     }
 183     return;
 184 }
 185
 186 sub check {
 187     my $self = shift;
 188     return $self->_compiled_type_constraint->(@_);
 189 }
 190
 191 sub coerce {
 192     my $self = shift;
 193
 194     return $_[0] if $self->_compiled_type_constraint->(@_);
 195
 196     my $coercion = $self->_compiled_type_coercion;
 197     return $coercion ? $coercion->(@_) : $_[0];
 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 !ref($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_02
 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