package Mouse::Meta::TypeConstraint;
use strict;
use warnings;
-use Carp ();
-use overload '""' => sub { shift->{name} }, # stringify to tc name
- fallback => 1;
+use overload
+ '""' => sub { shift->{name} }, # stringify to tc name
+ fallback => 1;
+
+use Carp qw(confess);
+use Scalar::Util qw(blessed reftype);
+
+use Mouse::Util qw(:meta);
+
+my $null_check = sub { 1 };
sub new {
- my $class = shift;
- my %args = @_;
- my $name = $args{name} || '__ANON__';
+ my($class, %args) = @_;
+
+ $args{name} = '__ANON__' if !defined $args{name};
+
+ my $check = $args{_compiled_type_constraint} || $args{constraint};
- my $check = $args{_compiled_type_constraint} or Carp::croak("missing _compiled_type_constraint");
- if (ref $check eq 'Mouse::Meta::TypeConstraint') {
+ if(blessed($check)){
+ Carp::cluck("'constraint' must be a CODE reference");
$check = $check->{_compiled_type_constraint};
}
- bless +{
- name => $name,
- _compiled_type_constraint => $check,
- message => $args{message}
- }, $class;
+ if(defined($check) && ref($check) ne 'CODE'){
+ confess("Type constraint for $args{name} is not a CODE reference");
+ }
+
+ my $self = bless \%args, $class;
+ $self->{_compiled_type_constraint} ||= $self->_compile();
+
+ return $self;
}
-sub name { shift->{name} }
+sub create_child_type{
+ my $self = shift;
+ return ref($self)->new(@_, parent => $self);
+}
+
+sub name { $_[0]->{name} }
+sub parent { $_[0]->{parent} }
+sub message { $_[0]->{message} }
sub check {
my $self = shift;
}
sub validate {
- my ($self, $value) = @_;\r
- if ($self->{_compiled_type_constraint}->($value)) {\r
- return undef;\r
- }\r
- else {\r
- $self->get_message($value);\r
- }\r
+ my ($self, $value) = @_;
+ if ($self->{_compiled_type_constraint}->($value)) {
+ return undef;
+ }
+ else {
+ $self->get_message($value);
+ }
}
-sub assert_valid {\r
- my ($self, $value) = @_;\r
-\r
- my $error = $self->validate($value);\r
- return 1 if ! defined $error;\r
-
- Carp::confess($error);\r
-}\r
+sub assert_valid {
+ my ($self, $value) = @_;
+ my $error = $self->validate($value);
+ return 1 if ! defined $error;
-sub message {
- return $_[0]->{message};
+ confess($error);
}
sub get_message {
}
}
+sub is_a_type_of{
+ my($self, $other) = @_;
+
+ # ->is_a_type_of('__ANON__') is always false
+ return 0 if !blessed($other) && $other eq '__ANON__';
+
+ (my $other_name = $other) =~ s/\s+//g;
+
+ return 1 if $self->name eq $other_name;
+
+ if(exists $self->{type_constraints}){ # union
+ foreach my $type(@{$self->{type_constraints}}){
+ return 1 if $type->name eq $other_name;
+ }
+ }
+
+ for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
+ return 1 if $parent->name eq $other_name;
+ }
+
+ return 0;
+}
+
+sub _compile{
+ my($self) = @_;
+
+ # add parents first
+ my @checks;
+ for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
+ if($parent->{constraint}){
+ push @checks, $parent->{constraint};
+ }
+ elsif($parent->{_compiled_type_constraint} && $parent->{_compiled_type_constraint} != $null_check){
+ # hand-optimized constraint
+ push @checks, $parent->{_compiled_type_constraint};
+ last;
+ }
+ }
+ # then add child
+ if($self->{constraint}){
+ push @checks, $self->{constraint};
+ }
+
+ if(@checks == 0){
+ return $null_check;
+ }
+ elsif(@checks == 1){
+ my $c = $checks[0];
+ return sub{
+ my(@args) = @_;
+ local $_ = $args[0];
+ return $c->(@args);
+ };
+ }
+ else{
+ return sub{
+ my(@args) = @_;
+ local $_ = $args[0];
+ foreach my $c(@checks){
+ return undef if !$c->(@args);
+ }
+ return 1;
+ };
+ }
+}
+
1;
__END__
=head1 NAME
-Mouse::Meta::TypeConstraint - The Mouse Type Constraint Metaclass
+Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
=head1 DESCRIPTION
=back
+=head1 SEE ALSO
+
+L<Moose::Meta::TypeConstraint>
+
=cut