Commit | Line | Data |
684db121 |
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 | |
29607c02 |
17 | bless +{ |
18 | name => $name, |
19 | _compiled_type_constraint => $check, |
20 | message => $args{message} |
21 | }, $class; |
684db121 |
22 | } |
23 | |
24 | sub name { shift->{name} } |
25 | |
26 | sub check { |
27 | my $self = shift; |
28 | $self->{_compiled_type_constraint}->(@_); |
29 | } |
30 | |
29607c02 |
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 | |
684db121 |
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 | |