package MooseX::Meta::TypeConstraint::Intersection;
our $VERSION = '0.03';
# ABSTRACT: An intersection of Moose type constraints
use Moose;
use MooseX::Types::Moose qw/ArrayRef/;
use Moose::Util::TypeConstraints 'find_type_constraint';
use aliased 'Moose::Meta::TypeConstraint';
use namespace::autoclean -also => 'TypeConstraint';
extends TypeConstraint;
has type_constraints => (
is => 'ro',
isa => ArrayRef[TypeConstraint],
default => sub { [] },
);
around new => sub {
my ($next, $class, %args) = @_;
my $name = join '&' => sort { $a cmp $b }
map { $_->name } @{ $args{type_constraints} };
return $class->$next(name => $name, %args);
};
sub _actually_compile_type_constraint {
my ($self) = @_;
my @type_constraints = @{ $self->type_constraints };
return sub {
my ($value) = @_;
for my $type (@type_constraints) {
return unless $type->check($value);
}
return 1;
};
}
# this is stolen from TC::Union. meh
sub equals {
my ($self, $type_or_name) = @_;
my $other = find_type_constraint($type_or_name);
return unless $other->isa(__PACKAGE__);
my @self_constraints = @{ $self->type_constraints };
my @other_constraints = @{ $other->type_constraints };
return unless @self_constraints == @other_constraints;
CONSTRAINT: for my $constraint (@self_constraints) {
for (my $i = 0; $i < @other_constraints; $i++) {
if ($constraint->equals($other_constraints[$i])) {
splice @other_constraints, $i, 1;
next CONSTRAINT;
}
}
}
return @other_constraints == 0;
}
# this too, although i'm not too sure what the point of it is
sub parents {
my ($self) = @_;
return $self->type_constraints;
}
sub validate {
my ($self, $value) = @_;
my $msgs = $self->validate_all($value);
return undef unless defined $msgs;
return join(q{ and } => map { $_->[0] } @{ $msgs }) . ' in ' . $self->name;
}
sub validate_all {
my ($self, $value) = @_;
my @msgs = map {
my $err = $_->validate($value);
defined $err ? [ $err, $_ ] : ();
} @{ $self->type_constraints };
return @msgs ? \@msgs : undef;
}
sub is_subtype_of {
my ($self, $type_or_name) = @_;
my $other = find_type_constraint($type_or_name);
return unless $other->isa(__PACKAGE__);
my @self_constraints = @{ $self->type_constraints };
my @other_constraints = @{ $other->type_constraints };
return if @self_constraints < @other_constraints;
CONSTRAINT: for my $tc (@other_constraints) {
for (my $i = 0; $i < @self_constraints; $i++) {
if ($tc->is_subtype_of($self_constraints[$i])) {
splice @self_constraints, $i, 1;
next CONSTRAINT;
}
}
}
return @self_constraints == 0;
}
1;
__END__
=pod
=head1 NAME
MooseX::Meta::TypeConstraint::Intersection - An intersection of Moose type constraints
=head1 VERSION
version 0.03
=head1 DESCRIPTION
This class represents an intersection of type constraints. An intersection
takes multiple type constraints, and is true if all of its member constraints
are true.
=head1 INHERITANCE
C is a subclass of
L.
=cut
=pod
=head1 ATTRIBUTES
=head2 type_constraints
The member type constraints of this intersection.
=cut
=pod
=head1 METHODS
=head2 new(%options)
This creates a new intersection type constraint based on the given C<%options>.
It takes the same options as its parent. It also requires an additional option,
C. This is an array reference containing the
L objects that are the members of the intersection
type. The C option defaults to the names of all of these member types
sorted and then joined by an ampersand (&).
=cut
=pod
=head2 check($value)
Checks a C<$value> against the intersection constraint. If all member
constraints accept the value, the value is valid and something true is
returned.
=cut
=pod
=head2 equals($other_constraint)
A type is considered equal if it is also an intersection type, and the two
intersections have the same member types.
=cut
=pod
=head2 parents
This returns the same constraint as the C method.
=cut
=pod
=head2 validate($value)
Like C, but returns an error message including all of the error messages
returned by the member constraints, or C.
=cut
=pod
=head2 validate_all($value)
Same as C, but returns an array reference of tuples with error
messages and the type constraints that produced them from the individual
validation errors instead of a plain string with the errors concatenated.
=cut
=pod
=head2 is_subtype_of($other_constraint)
This returns true if the C<$other_constraint> is also an intersection
constraint and contains at least all of the member constraints of the
intersection this method is called on.
=cut
=pod
=head1 THANKS
Ionzero LLC (L) for sponsoring the initial development.
=head1 AUTHOR
Florian Ragwitz
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by Florian Ragwitz.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut