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 sub is_a_type_of{
  73     my($self, $tc_name) = @_;
  74
  75     return $self->name eq $tc_name
  76         || $self->name =~ /\A $tc_name \[/xms; # "ArrayRef" =~ "ArrayRef[Foo]"
  77 }
  78
  79 1;
  80 __END__
  81
  82 =head1 NAME
  83
  84 Mouse::Meta::TypeConstraint - The Mouse Type Constraint Metaclass
  85
  86 =head1 DESCRIPTION
  87
  88 For the most part, the only time you will ever encounter an
  89 instance of this class is if you are doing some serious deep
  90 introspection. This API should not be considered final, but
  91 it is B<highly unlikely> that this will matter to a regular
  92 Mouse user.
  93
  94 Don't use this.
  95
  96 =head1 METHODS
  97
  98 =over 4
  99
 100 =item B<new>
 101
 102 =item B<name>
 103
 104 =back
 105
 106 =cut
 107