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