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