1 package MooseX::Meta::TypeConstraint::Structured::Named;
4 use Moose::Meta::TypeConstraint ();
5 use Moose::Util::TypeConstraints;
7 extends 'Moose::Meta::TypeConstraint';
11 MooseX::Meta::TypeConstraint::Structured::Named - Structured Type Constraints
19 our $VERSION = '0.01';
23 Structured type constraints let you assign an internal pattern of type
24 constraints to a 'container' constraint. The goal is to make it easier to
25 declare constraints like "ArrayRef[Int, Int, Str]" where the constraint is an
26 ArrayRef of three elements and the internal constraint on the three is Int, Int
29 To accomplish this, we add an attribute to the base L<Moose::Meta::TypeConstraint>
30 to hold a L</signature>, which is a reference to a pattern of type constraints.
31 We then override L</constraint> to check our incoming value to the attribute
32 against this signature pattern.
34 Named structured Constraints expect the internal constraints to be in keys or
35 fields similar to what we expect in a HashRef.
39 The following types are defined in this class.
41 =head2 Moose::Meta::TypeConstraint
43 Used to make sure we can properly validate incoming signatures.
47 class_type 'Moose::Meta::TypeConstraint';
51 This class defines the following attributes.
55 This is a signature of internal contraints for the contents of the outer
62 isa=>'HashRef[Moose::Meta::TypeConstraint]',
66 =head2 optional_signature
68 This is a signature of internal contraints for the contents of the outer
69 contraint container. These are optional constraints.
73 has 'optional_signature' => (
75 isa=>'HashRef[Moose::Meta::TypeConstraint]',
76 predicate=>'has_optional_signature',
81 This class defines the following methods.
83 =head2 _normalize_args
85 Get arguments into a known state or die trying. Ideally we try to make this
86 into a HashRef so we can match it up with the L</signature> HashRef.
91 my ($self, $args) = @_;
93 if(ref $args eq 'HASH') {
96 confess 'Signature must be an HashRef type';
99 confess 'Signature cannot be empty';
105 The constraint is basically validating the L</signature> against the incoming
112 my %args = $self->_normalize_args(shift);
113 my @signature = keys %{$self->signature};
114 my @ptional_signature = keys %{$self->optional_signature}
115 if $self->has_optional_signature;
117 ## First make sure all the required type constraints match
118 while( my $type_constraint_key = shift @signature) {
119 my $type_constraint = $self->signature->{$type_constraint_key};
120 if(my $error = $type_constraint->validate($args{$type_constraint_key})) {
123 delete $args{$type_constraint_key};
126 ## Now test the option type constraints.
127 while( my $arg_key = keys %args) {
128 my $optional_type_constraint = $self->signature->{$arg_key};
129 if(my $error = $optional_type_constraint->validate($args{$arg_key})) {
134 ## If we got this far we passed!
139 =head2 signature_equals
141 Check that the signature equals another signature.
145 sub signature_equals {
146 my ($self, $compared_type_constraint) = @_;
148 foreach my $idx (keys %{$self->signature}) {
149 my $this = $self->signature->{$idx};
150 my $that = $compared_type_constraint->signature->{$idx};
151 return unless $this->equals($that);
154 if($self->has_optional_signature) {
155 foreach my $idx (keys %{$self->optional_signature}) {
156 my $this = $self->optional_signature->{$idx};
157 my $that = $compared_type_constraint->optional_signature->{$idx};
158 return unless $this->equals($that);
167 modifier to make sure equals descends into the L</signature>
171 around 'equals' => sub {
172 my ($equals, $self, $compared_type_constraint) = @_;
174 ## Make sure we are comparing typeconstraints of the same base class
175 return unless $compared_type_constraint->isa(__PACKAGE__);
177 ## Make sure the base equals is also good
178 return unless $self->$equals($compared_type_constraint);
180 ## Make sure the signatures match
181 return unless $self->signature_equals($compared_type_constraint);
183 ## If we get this far, the two are equal
189 John James Napiorkowski <jjnapiork@cpan.org>
193 You may distribute this code under the same terms as Perl itself.