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     my $coercion = $self->_compiled_type_coercion;
 142     if(!$coercion){
 143         Carp::confess("Cannot coerce without a type coercion");
 144     }
 145
 146     return $_[0] if $self->_compiled_type_constraint->(@_);
 147
 148     return  $coercion->(@_);
 149 }
 150
 151 sub get_message {
 152     my ($self, $value) = @_;
 153     if ( my $msg = $self->message ) {
 154         local $_ = $value;
 155         return $msg->($value);
 156     }
 157     else {
 158         $value = ( defined $value ? overload::StrVal($value) : 'undef' );
 159         return "Validation failed for '$self' failed with value $value";
 160     }
 161 }
 162
 163 sub is_a_type_of{
 164     my($self, $other) = @_;
 165
 166     # ->is_a_type_of('__ANON__') is always false
 167     return 0 if !ref($other) && $other eq '__ANON__';
 168
 169     (my $other_name = $other) =~ s/\s+//g;
 170
 171     return 1 if $self->name eq $other_name;
 172
 173     if(exists $self->{type_constraints}){ # union
 174         foreach my $type(@{$self->{type_constraints}}){
 175             return 1 if $type->name eq $other_name;
 176         }
 177     }
 178
 179     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 180         return 1 if $parent->name eq $other_name;
 181     }
 182
 183     return 0;
 184 }
 185
 186 # See also Moose::Meta::TypeConstraint::Parameterizable
 187 sub parameterize{
 188     my($self, $param, $name) = @_;
 189
 190     if(!ref $param){
 191         require Mouse::Util::TypeConstraints;
 192         $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param);
 193     }
 194
 195     $name ||= sprintf '%s[%s]', $self->name, $param->name;
 196
 197     my $generator = $self->{constraint_generator}
 198         || Carp::confess("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");
 199
 200     return Mouse::Meta::TypeConstraint->new(
 201         name        => $name,
 202         parent      => $self,
 203         parameter   => $param,
 204         constraint  => $generator->($param), # must be 'constraint', not 'optimized'
 205
 206         type        => 'Parameterized',
 207     );
 208 }
 209
 210 1;
 211 __END__
 212
 213 =head1 NAME
 214
 215 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
 216
 217 =head1 VERSION
 218
 219 This document describes Mouse version 0.50
 220
 221 =head1 DESCRIPTION
 222
 223 For the most part, the only time you will ever encounter an
 224 instance of this class is if you are doing some serious deep
 225 introspection. This API should not be considered final, but
 226 it is B<highly unlikely> that this will matter to a regular
 227 Mouse user.
 228
 229 Don't use this.
 230
 231 =head1 METHODS
 232
 233 =over 4
 234
 235 =item B<new>
 236
 237 =item B<name>
 238
 239 =back
 240
 241 =head1 SEE ALSO
 242
 243 L<Moose::Meta::TypeConstraint>
 244
 245 =cut
 246