1 package Mouse::Meta::TypeConstraint;
6 '""' => sub { shift->{name} }, # stringify to tc name
10 use Scalar::Util qw(blessed reftype);
12 use Mouse::Util qw(:meta);
14 my $null_check = sub { 1 };
17 my($class, %args) = @_;
19 $args{name} = '__ANON__' if !defined $args{name};
21 my $check = delete $args{optimized};
23 if($args{_compiled_type_constraint}){
24 Carp::cluck("'_compiled_type_constraint' has been deprecated, use 'optimized' instead");
25 $check = $args{_compiled_type_constraint};
28 Carp::cluck("Constraint must be a CODE reference");
29 $check = $check->{compiled_type_constraint};
34 $args{hand_optimized_type_constraint} = $check;
35 $args{compiled_type_constraint} = $check;
38 $check = $args{constraint};
41 Carp::cluck("Constraint for $args{name} must be a CODE reference");
42 $check = $check->{compiled_type_constraint};
45 if(defined($check) && ref($check) ne 'CODE'){
46 confess("Constraint for $args{name} is not a CODE reference");
49 $args{package_defined_in} ||= caller;
51 my $self = bless \%args, $class;
52 $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
57 sub create_child_type{
60 return ref($self)->new(
61 # a child inherits its parent's attributes
64 # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
65 compiled_type_constraint => undef,
66 hand_optimized_type_constraint => undef,
68 # and is given child-specific args, of course.
76 sub name { $_[0]->{name} }
77 sub parent { $_[0]->{parent} }
78 sub message { $_[0]->{message} }
80 sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
83 sub compile_type_constraint{
88 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
89 if($parent->{hand_optimized_type_constraint}){
90 push @checks, $parent->{hand_optimized_type_constraint};
91 last; # a hand optimized constraint must include all the parents
93 elsif($parent->{constraint}){
94 push @checks, $parent->{constraint};
99 if($self->{constraint}){
100 push @checks, $self->{constraint};
103 if($self->{type_constraints}){ # Union
104 my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
106 foreach my $c(@types){
107 return 1 if $c->($_[0]);
114 $self->{compiled_type_constraint} = $null_check;
118 $self->{compiled_type_constraint} = sub{
125 $self->{compiled_type_constraint} = sub{
128 foreach my $c(@checks){
129 return undef if !$c->(@args);
139 $self->_compiled_type_constraint->(@_);
143 my ($self, $value) = @_;
144 if ( my $msg = $self->message ) {
146 return $msg->($value);
149 $value = ( defined $value ? overload::StrVal($value) : 'undef' );
150 return "Validation failed for '$self' failed with value $value";
155 my($self, $other) = @_;
157 # ->is_a_type_of('__ANON__') is always false
158 return 0 if !blessed($other) && $other eq '__ANON__';
160 (my $other_name = $other) =~ s/\s+//g;
162 return 1 if $self->name eq $other_name;
164 if(exists $self->{type_constraints}){ # union
165 foreach my $type(@{$self->{type_constraints}}){
166 return 1 if $type->name eq $other_name;
170 for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
171 return 1 if $parent->name eq $other_name;
183 Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
187 For the most part, the only time you will ever encounter an
188 instance of this class is if you are doing some serious deep
189 introspection. This API should not be considered final, but
190 it is B<highly unlikely> that this will matter to a regular
207 L<Moose::Meta::TypeConstraint>