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 = $args{_compiled_type_constraint} || $args{constraint};
  22
  23     if(blessed($check)){
  24         Carp::cluck("'constraint' must be a CODE reference");
  25         $check = $check->{_compiled_type_constraint};
  26     }
  27
  28     if(defined($check) && ref($check) ne 'CODE'){
  29         confess("Type constraint for $args{name} is not a CODE reference");
  30     }
  31
  32     my $self = bless \%args, $class;
  33     $self->{_compiled_type_constraint} ||= $self->_compile();
  34
  35     return $self;
  36 }
  37
  38 sub create_child_type{
  39     my $self = shift;
  40     return ref($self)->new(@_, parent => $self);
  41 }
  42
  43 sub name    { $_[0]->{name}    }
  44 sub parent  { $_[0]->{parent}  }
  45 sub message { $_[0]->{message} }
  46
  47 sub check {
  48     my $self = shift;
  49     $self->{_compiled_type_constraint}->(@_);
  50 }
  51
  52 sub validate {
  53     my ($self, $value) = @_;
  54     if ($self->{_compiled_type_constraint}->($value)) {
  55         return undef;
  56     }
  57     else {
  58         $self->get_message($value);
  59     }
  60 }
  61
  62 sub assert_valid {
  63     my ($self, $value) = @_;
  64
  65     my $error = $self->validate($value);
  66     return 1 if ! defined $error;
  67
  68     confess($error);
  69 }
  70
  71 sub get_message {
  72     my ($self, $value) = @_;
  73     if ( my $msg = $self->message ) {
  74         local $_ = $value;
  75         return $msg->($value);
  76     }
  77     else {
  78         $value = ( defined $value ? overload::StrVal($value) : 'undef' );
  79         return
  80             "Validation failed for '"
  81           . $self->name
  82           . "' failed with value $value";
  83     }
  84 }
  85
  86 sub is_a_type_of{
  87     my($self, $other) = @_;
  88
  89     # ->is_a_type_of('__ANON__') is always false
  90     return 0 if !blessed($other) && $other eq '__ANON__';
  91
  92     (my $other_name = $other) =~ s/\s+//g;
  93
  94     return 1 if $self->name eq $other_name;
  95
  96     if(exists $self->{type_constraints}){ # union
  97         foreach my $type(@{$self->{type_constraints}}){
  98             return 1 if $type->name eq $other_name;
  99         }
 100     }
 101
 102     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 103         return 1 if $parent->name eq $other_name;
 104     }
 105
 106     return 0;
 107 }
 108
 109 sub _compile{
 110     my($self) = @_;
 111
 112     # add parents first
 113     my @checks;
 114     for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
 115         if($parent->{constraint}){
 116             push @checks, $parent->{constraint};
 117          }
 118          elsif($parent->{_compiled_type_constraint} && $parent->{_compiled_type_constraint} != $null_check){
 119             # hand-optimized constraint
 120             push @checks, $parent->{_compiled_type_constraint};
 121             last;
 122         }
 123     }
 124     # then add child
 125     if($self->{constraint}){
 126         push @checks, $self->{constraint};
 127     }
 128
 129     if(@checks == 0){
 130         return $null_check;
 131     }
 132     elsif(@checks == 1){
 133         my $c = $checks[0];
 134         return sub{
 135             my(@args) = @_;
 136             local $_ = $args[0];
 137             return $c->(@args);
 138         };
 139     }
 140     else{
 141         return sub{
 142             my(@args) = @_;
 143             local $_ = $args[0];
 144             foreach my $c(@checks){
 145                 return undef if !$c->(@args);
 146             }
 147             return 1;
 148         };
 149     }
 150 }
 151
 152 1;
 153 __END__
 154
 155 =head1 NAME
 156
 157 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
 158
 159 =head1 DESCRIPTION
 160
 161 For the most part, the only time you will ever encounter an
 162 instance of this class is if you are doing some serious deep
 163 introspection. This API should not be considered final, but
 164 it is B<highly unlikely> that this will matter to a regular
 165 Mouse user.
 166
 167 Don't use this.
 168
 169 =head1 METHODS
 170
 171 =over 4
 172
 173 =item B<new>
 174
 175 =item B<name>
 176
 177 =back
 178
 179 =head1 SEE ALSO
 180
 181 L<Moose::Meta::TypeConstraint>
 182
 183 =cut
 184