lib/Mouse/Meta/TypeConstraint.pm

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