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