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