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