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