lib/Mouse/Meta/TypeConstraint.pm

   1 package Mouse::Meta::TypeConstraint;
   2 use strict;
   3 use warnings;
   4
   5 use overload
   6     '""'     => sub { shift->{name} },   # stringify to tc name
   7     fallback => 1;
   8
   9 use Carp qw(confess);
  10 use Scalar::Util qw(blessed reftype);
  11
  12 use Mouse::Util qw(:meta);
  13
  14 my $null_check = sub { 1 };
  15
  16 sub new {
  17     my($class, %args) = @_;
  18
  19     $args{name} = '__ANON__' if !defined $args{name};
  20
  21     my $check = delete $args{optimized};
  22
  23     if($args{_compiled_type_constraint}){
  24         Carp::cluck("'_compiled_type_constraint' has been deprecated, use 'optimized' instead");
  25         $check = $args{_compiled_type_constraint};
  26
  27         if(blessed($check)){
  28             Carp::cluck("Constraint must be a CODE reference");
  29             $check = $check->{compiled_type_constraint};
  30         }
  31     }
  32
  33     if($check){
  34         $args{hand_optimized_type_constraint} = $check;
  35         $args{compiled_type_constraint}       = $check;
  36     }
  37
  38     $check = $args{constraint};
  39
  40     if(blessed($check)){
  41         Carp::cluck("Constraint for $args{name} must be a CODE reference");
  42         $check = $check->{compiled_type_constraint};
  43     }
  44
  45     if(defined($check) && ref($check) ne 'CODE'){
  46         confess("Constraint for $args{name} is not a CODE reference");
  47     }
  48
  49     $args{package_defined_in} ||= caller;
  50
  51     my $self = bless \%args, $class;
  52     $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
  53
  54     return $self;
  55 }
  56
  57 sub create_child_type{
  58     my $self = shift;
  59     # XXX: FIXME
  60     return ref($self)->new(
  61         # a child inherits its parent's attributes
  62         %{$self},
  63
  64         # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
  65         compiled_type_constraint       => undef,
  66         hand_optimized_type_constraint => undef,
  67
  68         # and is given child-specific args, of course.
  69         @_,
  70
  71         # and its parent
  72         parent => $self,
  73    );
  74 }
  75
  76 sub name    { $_[0]->{name}    }
  77 sub parent  { $_[0]->{parent}  }
  78 sub message { $_[0]->{message} }
  79
  80 sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
  81
  82
  83 sub compile_type_constraint{
  84     my($self) = @_;
  85
  86     # add parents first
  87     my @checks;
  88     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
  89          if($parent->{hand_optimized_type_constraint}){
  90             push @checks, $parent->{hand_optimized_type_constraint};
  91             last; # a hand optimized constraint must include all the parents
  92         }
  93         elsif($parent->{constraint}){
  94             push @checks, $parent->{constraint};
  95         }
  96     }
  97
  98     # then add child
  99     if($self->{constraint}){
 100         push @checks, $self->{constraint};
 101     }
 102
 103     if($self->{type_constraints}){ # Union
 104         my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
 105         push @checks, sub{
 106             foreach my $c(@types){
 107                 return 1 if $c->($_[0]);
 108             }
 109             return 0;
 110         };
 111     }
 112
 113     if(@checks == 0){
 114         $self->{compiled_type_constraint} = $null_check;
 115     }
 116     elsif(@checks == 1){
 117         my $c = $checks[0];
 118         $self->{compiled_type_constraint} = sub{
 119             my(@args) = @_;
 120             local $_ = $args[0];
 121             return $c->(@args);
 122         };
 123     }
 124     else{
 125         $self->{compiled_type_constraint} =  sub{
 126             my(@args) = @_;
 127             local $_ = $args[0];
 128             foreach my $c(@checks){
 129                 return undef if !$c->(@args);
 130             }
 131             return 1;
 132         };
 133     }
 134     return;
 135 }
 136
 137 sub check {
 138     my $self = shift;
 139     $self->_compiled_type_constraint->(@_);
 140 }
 141
 142 sub get_message {
 143     my ($self, $value) = @_;
 144     if ( my $msg = $self->message ) {
 145         local $_ = $value;
 146         return $msg->($value);
 147     }
 148     else {
 149         $value = ( defined $value ? overload::StrVal($value) : 'undef' );
 150         return "Validation failed for '$self' failed with value $value";
 151     }
 152 }
 153
 154 sub is_a_type_of{
 155     my($self, $other) = @_;
 156
 157     # ->is_a_type_of('__ANON__') is always false
 158     return 0 if !blessed($other) && $other eq '__ANON__';
 159
 160     (my $other_name = $other) =~ s/\s+//g;
 161
 162     return 1 if $self->name eq $other_name;
 163
 164     if(exists $self->{type_constraints}){ # union
 165         foreach my $type(@{$self->{type_constraints}}){
 166             return 1 if $type->name eq $other_name;
 167         }
 168     }
 169
 170     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 171         return 1 if $parent->name eq $other_name;
 172     }
 173
 174     return 0;
 175 }
 176
 177
 178 1;
 179 __END__
 180
 181 =head1 NAME
 182
 183 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
 184
 185 =head1 DESCRIPTION
 186
 187 For the most part, the only time you will ever encounter an
 188 instance of this class is if you are doing some serious deep
 189 introspection. This API should not be considered final, but
 190 it is B<highly unlikely> that this will matter to a regular
 191 Mouse user.
 192
 193 Don't use this.
 194
 195 =head1 METHODS
 196
 197 =over 4
 198
 199 =item B<new>
 200
 201 =item B<name>
 202
 203 =back
 204
 205 =head1 SEE ALSO
 206
 207 L<Moose::Meta::TypeConstraint>
 208
 209 =cut
 210