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