lib/Mouse/Meta/TypeConstraint.pm

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