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     '""'     => sub { $_[0]->name },   # stringify to tc name
   7     '|'      => sub {                  # or-combination
   8         require Mouse::Util::TypeConstraints;
   9         return Mouse::Util::TypeConstraints::find_or_parse_type_constraint(
  10             "$_[0] | $_[1]",
  11         );
  12     },
  13
  14     fallback => 1;
  15
  16 sub new {
  17     my($class, %args) = @_;
  18
  19     $args{name} = '__ANON__' if !defined $args{name};
  20
  21     my $check = delete $args{optimized};
  22
  23     if($check){
  24         $args{hand_optimized_type_constraint} = $check;
  25         $args{compiled_type_constraint}       = $check;
  26     }
  27
  28     $check = $args{constraint};
  29
  30     if(defined($check) && ref($check) ne 'CODE'){
  31         $class->throw_error("Constraint for $args{name} is not a CODE reference");
  32     }
  33
  34     my $self = bless \%args, $class;
  35     $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
  36
  37     $self->_compile_union_type_coercion() if $self->{type_constraints};
  38     return $self;
  39 }
  40
  41 sub create_child_type{
  42     my $self = shift;
  43     return ref($self)->new(
  44         # a child inherits its parent's attributes
  45         %{$self},
  46
  47         # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
  48         compiled_type_constraint       => undef,
  49         hand_optimized_type_constraint => undef,
  50
  51         # and is given child-specific args, of course.
  52         @_,
  53
  54         # and its parent
  55         parent => $self,
  56    );
  57 }
  58
  59 sub name;
  60 sub parent;
  61 sub message;
  62 sub has_coercion;
  63
  64 sub check;
  65
  66 sub type_parameter;
  67 sub __is_parameterized;
  68
  69 sub _compiled_type_constraint;
  70 sub _compiled_type_coercion;
  71
  72 sub compile_type_constraint;
  73
  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             $self->throw_error("A coercion action already exists for '$from'");
  87         }
  88
  89         my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
  90             or $self->throw_error("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         $self->throw_error("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 coerce {
 147     my $self = shift;
 148
 149     my $coercion = $self->_compiled_type_coercion;
 150     if(!$coercion){
 151         $self->throw_error("Cannot coerce without a type coercion");
 152     }
 153
 154     return $_[0] if $self->check(@_);
 155
 156     return  $coercion->(@_);
 157 }
 158
 159 sub get_message {
 160     my ($self, $value) = @_;
 161     if ( my $msg = $self->message ) {
 162         local $_ = $value;
 163         return $msg->($value);
 164     }
 165     else {
 166         $value = ( defined $value ? overload::StrVal($value) : 'undef' );
 167         return "Validation failed for '$self' failed with value $value";
 168     }
 169 }
 170
 171 sub is_a_type_of{
 172     my($self, $other) = @_;
 173
 174     # ->is_a_type_of('__ANON__') is always false
 175     return 0 if !ref($other) && $other eq '__ANON__';
 176
 177     (my $other_name = $other) =~ s/\s+//g;
 178
 179     return 1 if $self->name eq $other_name;
 180
 181     if(exists $self->{type_constraints}){ # union
 182         foreach my $type(@{$self->{type_constraints}}){
 183             return 1 if $type->name eq $other_name;
 184         }
 185     }
 186
 187     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 188         return 1 if $parent->name eq $other_name;
 189     }
 190
 191     return 0;
 192 }
 193
 194 # See also Moose::Meta::TypeConstraint::Parameterizable
 195 sub parameterize{
 196     my($self, $param, $name) = @_;
 197
 198     if(!ref $param){
 199         require Mouse::Util::TypeConstraints;
 200         $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param);
 201     }
 202
 203     $name ||= sprintf '%s[%s]', $self->name, $param->name;
 204
 205     my $generator = $self->{constraint_generator}
 206         || $self->throw_error("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");
 207
 208     return Mouse::Meta::TypeConstraint->new(
 209         name           => $name,
 210         parent         => $self,
 211         type_parameter => $param,
 212         constraint     => $generator->($param), # must be 'constraint', not 'optimized'
 213     );
 214 }
 215
 216 sub assert_valid {
 217     my ($self, $value) = @_;
 218
 219     if(!$self->check($value)){
 220         $self->throw_error($self->get_message($value));
 221     }
 222     return 1;
 223 }
 224
 225 sub throw_error {
 226     require Mouse::Meta::Module;
 227     goto &Mouse::Meta::Module::throw_error;
 228 }
 229
 230 1;
 231 __END__
 232
 233 =head1 NAME
 234
 235 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
 236
 237 =head1 VERSION
 238
 239 This document describes Mouse version 0.59
 240
 241 =head1 DESCRIPTION
 242
 243 For the most part, the only time you will ever encounter an
 244 instance of this class is if you are doing some serious deep
 245 introspection. This API should not be considered final, but
 246 it is B<highly unlikely> that this will matter to a regular
 247 Mouse user.
 248
 249 Don't use this.
 250
 251 =head1 METHODS
 252
 253 =over 4
 254
 255 =item B<new>
 256
 257 =item B<name>
 258
 259 =back
 260
 261 =head1 SEE ALSO
 262
 263 L<Moose::Meta::TypeConstraint>
 264
 265 =cut
 266