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