lib/Mouse/Meta/TypeConstraint.pm

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