lib/Mouse/Meta/TypeConstraint.pm

   1 package Mouse::Meta::TypeConstraint;
   2 use strict;
   3 use warnings;
   4 use overload '""'     => sub { shift->{name} },   # stringify to tc name
   5              fallback => 1;
   6
   7 sub new {
   8     my $class = shift;
   9     my %args = @_;
  10     my $name = $args{name} || '__ANON__';
  11
  12     my $check = $args{_compiled_type_constraint} or Carp::croak("missing _compiled_type_constraint");
  13     if (ref $check eq 'Mouse::Meta::TypeConstraint') {
  14         $check = $check->{_compiled_type_constraint};
  15     }
  16
  17     bless +{
  18         name                      => $name,
  19         _compiled_type_constraint => $check,
  20         message                   => $args{message}
  21     }, $class;
  22 }
  23
  24 sub name { shift->{name} }
  25
  26 sub check {
  27     my $self = shift;
  28     $self->{_compiled_type_constraint}->(@_);
  29 }
  30
  31 sub message {
  32     return $_[0]->{message};
  33 }
  34
  35 sub get_message {
  36     my ($self, $value) = @_;
  37     if ( my $msg = $self->message ) {
  38         local $_ = $value;
  39         return $msg->($value);
  40     }
  41     else {
  42         $value = ( defined $value ? overload::StrVal($value) : 'undef' );
  43         return
  44             "Validation failed for '"
  45           . $self->name
  46           . "' failed with value $value";
  47     }
  48 }
  49
  50 1;
  51 __END__
  52
  53 =head1 NAME
  54
  55 Mouse::Meta::TypeConstraint - The Mouse Type Constraint Metaclass
  56
  57 =head1 DESCRIPTION
  58
  59 For the most part, the only time you will ever encounter an
  60 instance of this class is if you are doing some serious deep
  61 introspection. This API should not be considered final, but
  62 it is B<highly unlikely> that this will matter to a regular
  63 Mouse user.
  64
  65 Don't use this.
  66
  67 =head1 METHODS
  68
  69 =over 4
  70
  71 =item B<new>
  72
  73 =item B<name>
  74
  75 =back
  76
  77 =cut
  78