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