lib/Mouse/Meta/TypeConstraint.pm

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