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