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 # See also Moose::Meta::TypeConstraint::Parameterizable
 238 sub parameterize{
 239     my($self, $param, $name) = @_;
 240
 241     if(!ref $param){
 242         require Mouse::Util::TypeConstraints;
 243         $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param);
 244     }
 245
 246     $name ||= sprintf '%s[%s]', $self->name, $param->name;
 247
 248     my $generator = $self->{constraint_generator}
 249         || Carp::confess("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");
 250
 251     return Mouse::Meta::TypeConstraint->new(
 252         name               => $name,
 253         parent             => $self,
 254         constraint         => $generator->($param),
 255
 256         type               => 'Parameterized',
 257     );
 258 }
 259
 260 1;
 261 __END__
 262
 263 =head1 NAME
 264
 265 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
 266
 267 =head1 VERSION
 268
 269 This document describes Mouse version 0.40_03
 270
 271 =head1 DESCRIPTION
 272
 273 For the most part, the only time you will ever encounter an
 274 instance of this class is if you are doing some serious deep
 275 introspection. This API should not be considered final, but
 276 it is B<highly unlikely> that this will matter to a regular
 277 Mouse user.
 278
 279 Don't use this.
 280
 281 =head1 METHODS
 282
 283 =over 4
 284
 285 =item B<new>
 286
 287 =item B<name>
 288
 289 =back
 290
 291 =head1 SEE ALSO
 292
 293 L<Moose::Meta::TypeConstraint>
 294
 295 =cut
 296