lib/Mouse/Meta/TypeConstraint.pm

   1 package Mouse::Meta::TypeConstraint;
   2 use Mouse::Util qw(:meta); # enables strict and warnings
   3 use Scalar::Util ();
   4
   5 sub new {
   6     my $class = shift;
   7     my %args  = @_ == 1 ? %{$_[0]} : @_;
   8
   9     $args{name} = '__ANON__' if !defined $args{name};
  10
  11     my $check = delete $args{optimized};
  12
  13     if($check){
  14         $args{hand_optimized_type_constraint} = $check;
  15         $args{compiled_type_constraint}       = $check;
  16     }
  17
  18     $check = $args{constraint};
  19
  20     if(defined($check) && ref($check) ne 'CODE'){
  21         $class->throw_error("Constraint for $args{name} is not a CODE reference");
  22     }
  23
  24     my $self = bless \%args, $class;
  25     $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
  26
  27     $self->_compile_union_type_coercion() if $self->{type_constraints};
  28     return $self;
  29 }
  30
  31 sub create_child_type{
  32     my $self = shift;
  33     return ref($self)->new(
  34         # a child inherits its parent's attributes
  35         %{$self},
  36
  37         # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
  38         compiled_type_constraint       => undef,
  39         hand_optimized_type_constraint => undef,
  40
  41         # and is given child-specific args, of course.
  42         @_,
  43
  44         # and its parent
  45         parent => $self,
  46    );
  47 }
  48
  49 sub name;
  50 sub parent;
  51 sub message;
  52 sub has_coercion;
  53
  54 sub check;
  55
  56 sub type_parameter;
  57 sub __is_parameterized;
  58
  59 sub _compiled_type_constraint;
  60 sub _compiled_type_coercion;
  61
  62 sub compile_type_constraint;
  63
  64
  65 sub _add_type_coercions{
  66     my $self = shift;
  67
  68     my $coercions = ($self->{coercion_map} ||= []);
  69     my %has       = map{ $_->[0] => undef } @{$coercions};
  70
  71     for(my $i = 0; $i < @_; $i++){
  72         my $from   = $_[  $i];
  73         my $action = $_[++$i];
  74
  75         if(exists $has{$from}){
  76             $self->throw_error("A coercion action already exists for '$from'");
  77         }
  78
  79         my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
  80             or $self->throw_error("Could not find the type constraint ($from) to coerce from");
  81
  82         push @{$coercions}, [ $type => $action ];
  83     }
  84
  85     # compile
  86     if(exists $self->{type_constraints}){ # union type
  87         $self->throw_error("Cannot add additional type coercions to Union types");
  88     }
  89     else{
  90         $self->_compile_type_coercion();
  91     }
  92     return;
  93 }
  94
  95 sub _compile_type_coercion {
  96     my($self) = @_;
  97
  98     my @coercions = @{$self->{coercion_map}};
  99
 100     $self->{_compiled_type_coercion} = sub {
 101        my($thing) = @_;
 102        foreach my $pair (@coercions) {
 103             #my ($constraint, $converter) = @$pair;
 104             if ($pair->[0]->check($thing)) {
 105               local $_ = $thing;
 106               return $pair->[1]->($thing);
 107             }
 108        }
 109        return $thing;
 110     };
 111     return;
 112 }
 113
 114 sub _compile_union_type_coercion {
 115     my($self) = @_;
 116
 117     my @coercions;
 118     foreach my $type(@{$self->{type_constraints}}){
 119         if($type->has_coercion){
 120             push @coercions, $type;
 121         }
 122     }
 123     if(@coercions){
 124         $self->{_compiled_type_coercion} = sub {
 125             my($thing) = @_;
 126             foreach my $type(@coercions){
 127                 my $value = $type->coerce($thing);
 128                 return $value if $self->check($value);
 129             }
 130             return $thing;
 131         };
 132     }
 133     return;
 134 }
 135
 136 sub coerce {
 137     my $self = shift;
 138
 139     my $coercion = $self->_compiled_type_coercion;
 140     if(!$coercion){
 141         $self->throw_error("Cannot coerce without a type coercion");
 142     }
 143
 144     return $_[0] if $self->check(@_);
 145
 146     return  $coercion->(@_);
 147 }
 148
 149 sub get_message {
 150     my ($self, $value) = @_;
 151     if ( my $msg = $self->message ) {
 152         local $_ = $value;
 153         return $msg->($value);
 154     }
 155     else {
 156         if(not defined $value) {
 157             $value = 'undef';
 158         }
 159         elsif( ref($value) && defined(&overload::StrVal) ) {
 160             $value = overload::StrVal($value);
 161         }
 162         return "Validation failed for '$self' with value $value";
 163     }
 164 }
 165
 166 sub is_a_type_of{
 167     my($self, $other) = @_;
 168
 169     # ->is_a_type_of('__ANON__') is always false
 170     return 0 if !ref($other) && $other eq '__ANON__';
 171
 172     (my $other_name = $other) =~ s/\s+//g;
 173
 174     return 1 if $self->name eq $other_name;
 175
 176     if(exists $self->{type_constraints}){ # union
 177         foreach my $type(@{$self->{type_constraints}}){
 178             return 1 if $type->name eq $other_name;
 179         }
 180     }
 181
 182     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 183         return 1 if $parent->name eq $other_name;
 184     }
 185
 186     return 0;
 187 }
 188
 189 # See also Moose::Meta::TypeConstraint::Parameterizable
 190 sub parameterize{
 191     my($self, $param, $name) = @_;
 192
 193     if(!ref $param){
 194         require Mouse::Util::TypeConstraints;
 195         $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param);
 196     }
 197
 198     $name ||= sprintf '%s[%s]', $self->name, $param->name;
 199
 200     my $generator = $self->{constraint_generator}
 201         || $self->throw_error("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");
 202
 203     return Mouse::Meta::TypeConstraint->new(
 204         name           => $name,
 205         parent         => $self,
 206         type_parameter => $param,
 207         constraint     => $generator->($param), # must be 'constraint', not 'optimized'
 208     );
 209 }
 210
 211 sub assert_valid {
 212     my ($self, $value) = @_;
 213
 214     if(!$self->check($value)){
 215         $self->throw_error($self->get_message($value));
 216     }
 217     return 1;
 218 }
 219
 220 sub _as_string { $_[0]->name                  } # overload ""
 221 sub _identity  { Scalar::Util::refaddr($_[0]) } # overload 0+
 222
 223 sub _unite { # overload infix:<|>
 224     my($lhs, $rhs) = @_;
 225     require Mouse::Util::TypeConstraints;
 226     return Mouse::Util::TypeConstraints::find_or_parse_type_constraint(
 227        " $lhs | $rhs",
 228     );
 229 }
 230
 231 sub throw_error {
 232     require Mouse::Meta::Module;
 233     goto &Mouse::Meta::Module::throw_error;
 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.70
 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