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     else{
 128         $self->{compiled_type_constraint} =  sub{
 129             my(@args) = @_;
 130             local $_ = $args[0];
 131             foreach my $c(@checks){
 132                 return undef if !$c->(@args);
 133             }
 134             return 1;
 135         };
 136     }
 137     return;
 138 }
 139
 140 sub _add_type_coercions{
 141     my $self = shift;
 142
 143     my $coercions = ($self->{_coercion_map} ||= []);
 144     my %has       = map{ $_->[0] => undef } @{$coercions};
 145
 146     for(my $i = 0; $i < @_; $i++){
 147         my $from   = $_[  $i];
 148         my $action = $_[++$i];
 149
 150         if(exists $has{$from}){
 151             Carp::confess("A coercion action already exists for '$from'");
 152         }
 153
 154         my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
 155             or Carp::confess("Could not find the type constraint ($from) to coerce from");
 156
 157         push @{$coercions}, [ $type => $action ];
 158     }
 159
 160     # compile
 161     if(exists $self->{type_constraints}){ # union type
 162         Carp::confess("Cannot add additional type coercions to Union types");
 163     }
 164     else{
 165         $self->{_compiled_type_coercion} = sub {
 166            my($thing) = @_;\r
 167            foreach my $pair (@{$coercions}) {\r
 168                 #my ($constraint, $converter) = @$pair;\r
 169                 if ($pair->[0]->check($thing)) {\r
 170                   local $_ = $thing;
 171                   return $pair->[1]->($thing);
 172                 }\r
 173            }\r
 174            return $thing;\r
 175         };
 176     }
 177     return;
 178 }
 179
 180 sub check {
 181     my $self = shift;
 182     return $self->_compiled_type_constraint->(@_);
 183 }
 184
 185 sub coerce {
 186     my $self = shift;
 187
 188     return $_[0] if $self->_compiled_type_constraint->(@_);
 189
 190     my $coercion = $self->_compiled_type_coercion;
 191     return $coercion ? $coercion->(@_) : $_[0];
 192 }
 193
 194 sub get_message {
 195     my ($self, $value) = @_;
 196     if ( my $msg = $self->message ) {
 197         local $_ = $value;
 198         return $msg->($value);
 199     }
 200     else {
 201         $value = ( defined $value ? overload::StrVal($value) : 'undef' );
 202         return "Validation failed for '$self' failed with value $value";
 203     }
 204 }
 205
 206 sub is_a_type_of{
 207     my($self, $other) = @_;
 208
 209     # ->is_a_type_of('__ANON__') is always false
 210     return 0 if !ref($other) && $other eq '__ANON__';
 211
 212     (my $other_name = $other) =~ s/\s+//g;
 213
 214     return 1 if $self->name eq $other_name;
 215
 216     if(exists $self->{type_constraints}){ # union
 217         foreach my $type(@{$self->{type_constraints}}){
 218             return 1 if $type->name eq $other_name;
 219         }
 220     }
 221
 222     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 223         return 1 if $parent->name eq $other_name;
 224     }
 225
 226     return 0;
 227 }
 228
 229 # See also Moose::Meta::TypeConstraint::Parameterizable
 230 sub parameterize{
 231     my($self, $param, $name) = @_;
 232
 233     if(!ref $param){
 234         require Mouse::Util::TypeConstraints;
 235         $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param);
 236     }
 237
 238     $name ||= sprintf '%s[%s]', $self->name, $param->name;
 239
 240     my $generator = $self->{constraint_generator}
 241         || Carp::confess("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");
 242
 243     return Mouse::Meta::TypeConstraint->new(
 244         name        => $name,
 245         parent      => $self,
 246         parameter   => $param,
 247         constraint  => $generator->($param), # must be 'constraint', not 'optimized'
 248
 249         type        => 'Parameterized',
 250     );
 251 }
 252
 253 1;
 254 __END__
 255
 256 =head1 NAME
 257
 258 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
 259
 260 =head1 VERSION
 261
 262 This document describes Mouse version 0.40_03
 263
 264 =head1 DESCRIPTION
 265
 266 For the most part, the only time you will ever encounter an
 267 instance of this class is if you are doing some serious deep
 268 introspection. This API should not be considered final, but
 269 it is B<highly unlikely> that this will matter to a regular
 270 Mouse user.
 271
 272 Don't use this.
 273
 274 =head1 METHODS
 275
 276 =over 4
 277
 278 =item B<new>
 279
 280 =item B<name>
 281
 282 =back
 283
 284 =head1 SEE ALSO
 285
 286 L<Moose::Meta::TypeConstraint>
 287
 288 =cut
 289