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