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 sub check {
  83     my $self = shift;
  84     $self->_compiled_type_constraint->(@_);
  85 }
  86
  87 sub validate {
  88     my ($self, $value) = @_;
  89     if ($self->_compiled_type_constraint->($value)) {
  90         return undef;
  91     }
  92     else {
  93         $self->get_message($value);
  94     }
  95 }
  96
  97 sub assert_valid {
  98     my ($self, $value) = @_;
  99
 100     my $error = $self->validate($value);
 101     return 1 if ! defined $error;
 102
 103     confess($error);
 104 }
 105
 106 sub get_message {
 107     my ($self, $value) = @_;
 108     if ( my $msg = $self->message ) {
 109         local $_ = $value;
 110         return $msg->($value);
 111     }
 112     else {
 113         $value = ( defined $value ? overload::StrVal($value) : 'undef' );
 114         return
 115             "Validation failed for '"
 116           . $self->name
 117           . "' failed with value $value";
 118     }
 119 }
 120
 121 sub is_a_type_of{
 122     my($self, $other) = @_;
 123
 124     # ->is_a_type_of('__ANON__') is always false
 125     return 0 if !blessed($other) && $other eq '__ANON__';
 126
 127     (my $other_name = $other) =~ s/\s+//g;
 128
 129     return 1 if $self->name eq $other_name;
 130
 131     if(exists $self->{type_constraints}){ # union
 132         foreach my $type(@{$self->{type_constraints}}){
 133             return 1 if $type->name eq $other_name;
 134         }
 135     }
 136
 137     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 138         return 1 if $parent->name eq $other_name;
 139     }
 140
 141     return 0;
 142 }
 143
 144 sub compile_type_constraint{
 145     my($self) = @_;
 146
 147     # add parents first
 148     my @checks;
 149     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 150          if($parent->{hand_optimized_type_constraint}){
 151             push @checks, $parent->{hand_optimized_type_constraint};
 152             last; # a hand optimized constraint must include all the parents
 153         }
 154         elsif($parent->{constraint}){
 155             push @checks, $parent->{constraint};
 156         }
 157     }
 158
 159     # then add child
 160     if($self->{constraint}){
 161         push @checks, $self->{constraint};
 162     }
 163
 164     if($self->{type_constraints}){ # Union
 165         my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
 166         push @checks, sub{
 167             foreach my $c(@types){
 168                 return 1 if $c->($_[0]);
 169             }
 170             return 0;
 171         };
 172     }
 173
 174     if(@checks == 0){
 175         $self->{compiled_type_constraint} = $null_check;
 176     }
 177     elsif(@checks == 1){
 178         my $c = $checks[0];
 179         $self->{compiled_type_constraint} = sub{
 180             my(@args) = @_;
 181             local $_ = $args[0];
 182             return $c->(@args);
 183         };
 184     }
 185     else{
 186         $self->{compiled_type_constraint} =  sub{
 187             my(@args) = @_;
 188             local $_ = $args[0];
 189             foreach my $c(@checks){
 190                 return undef if !$c->(@args);
 191             }
 192             return 1;
 193         };
 194     }
 195     return;
 196 }
 197
 198 1;
 199 __END__
 200
 201 =head1 NAME
 202
 203 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
 204
 205 =head1 DESCRIPTION
 206
 207 For the most part, the only time you will ever encounter an
 208 instance of this class is if you are doing some serious deep
 209 introspection. This API should not be considered final, but
 210 it is B<highly unlikely> that this will matter to a regular
 211 Mouse user.
 212
 213 Don't use this.
 214
 215 =head1 METHODS
 216
 217 =over 4
 218
 219 =item B<new>
 220
 221 =item B<name>
 222
 223 =back
 224
 225 =head1 SEE ALSO
 226
 227 L<Moose::Meta::TypeConstraint>
 228
 229 =cut
 230