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