Commit | Line | Data |
9a491c80 |
1 | package MooseX::Meta::TypeConstraint::Structured::Named; |
2 | |
3 | use Moose; |
4 | use Moose::Meta::TypeConstraint (); |
9a491c80 |
5 | |
6 | extends 'Moose::Meta::TypeConstraint'; |
bc5c0758 |
7 | with 'MooseX::Meta::TypeConstraint::Role::Structured'; |
9a491c80 |
8 | |
9 | =head1 NAME |
10 | |
11 | MooseX::Meta::TypeConstraint::Structured::Named - Structured Type Constraints |
12 | |
9a491c80 |
13 | =head1 DESCRIPTION |
14 | |
15 | Structured type constraints let you assign an internal pattern of type |
16 | constraints to a 'container' constraint. The goal is to make it easier to |
17 | declare constraints like "ArrayRef[Int, Int, Str]" where the constraint is an |
18 | ArrayRef of three elements and the internal constraint on the three is Int, Int |
19 | and Str. |
20 | |
21 | To accomplish this, we add an attribute to the base L<Moose::Meta::TypeConstraint> |
22 | to hold a L</signature>, which is a reference to a pattern of type constraints. |
23 | We then override L</constraint> to check our incoming value to the attribute |
24 | against this signature pattern. |
25 | |
26 | Named structured Constraints expect the internal constraints to be in keys or |
27 | fields similar to what we expect in a HashRef. |
28 | |
9a491c80 |
29 | =head1 ATTRIBUTES |
30 | |
31 | This class defines the following attributes. |
32 | |
33 | =head2 signature |
34 | |
35 | This is a signature of internal contraints for the contents of the outer |
36 | contraint container. |
37 | |
38 | =cut |
39 | |
24dd1d2e |
40 | has '+signature' => (isa=>'HashRef[Moose::Meta::TypeConstraint]'); |
9a491c80 |
41 | |
42 | =head2 optional_signature |
43 | |
44 | This is a signature of internal contraints for the contents of the outer |
45 | contraint container. These are optional constraints. |
46 | |
47 | =cut |
48 | |
24dd1d2e |
49 | has '+optional_signature' => (isa=>'HashRef[Moose::Meta::TypeConstraint]'); |
9a491c80 |
50 | |
51 | =head1 METHODS |
52 | |
53 | This class defines the following methods. |
54 | |
55 | =head2 _normalize_args |
56 | |
57 | Get arguments into a known state or die trying. Ideally we try to make this |
58 | into a HashRef so we can match it up with the L</signature> HashRef. |
59 | |
60 | =cut |
61 | |
62 | sub _normalize_args { |
63 | my ($self, $args) = @_; |
64 | if(defined $args) { |
65 | if(ref $args eq 'HASH') { |
66 | %$args |
67 | } else { |
68 | confess 'Signature must be an HashRef type'; |
69 | } |
70 | } else { |
71 | confess 'Signature cannot be empty'; |
72 | } |
73 | } |
74 | |
75 | =head2 constraint |
76 | |
77 | The constraint is basically validating the L</signature> against the incoming |
78 | |
79 | =cut |
80 | |
81 | sub constraint { |
82 | my $self = shift; |
83 | return sub { |
84 | my %args = $self->_normalize_args(shift); |
9a491c80 |
85 | |
86 | ## First make sure all the required type constraints match |
6479ca33 |
87 | foreach my $sig_key (keys %{$self->signature}) { |
88 | my $type_constraint = $self->signature->{$sig_key}; |
89 | if(my $error = $type_constraint->validate($args{$sig_key})) { |
9a491c80 |
90 | confess $error; |
6479ca33 |
91 | } else { |
92 | delete $args{$sig_key}; |
9a491c80 |
93 | } |
9a491c80 |
94 | } |
95 | |
96 | ## Now test the option type constraints. |
6479ca33 |
97 | foreach my $arg_key (keys %args) { |
98 | my $optional_type_constraint = $self->optional_signature->{$arg_key}; |
9a491c80 |
99 | if(my $error = $optional_type_constraint->validate($args{$arg_key})) { |
100 | confess $error; |
101 | } |
102 | } |
103 | |
104 | ## If we got this far we passed! |
105 | return 1; |
106 | }; |
107 | } |
108 | |
109 | =head2 signature_equals |
110 | |
111 | Check that the signature equals another signature. |
112 | |
113 | =cut |
114 | |
115 | sub signature_equals { |
116 | my ($self, $compared_type_constraint) = @_; |
117 | |
118 | foreach my $idx (keys %{$self->signature}) { |
119 | my $this = $self->signature->{$idx}; |
120 | my $that = $compared_type_constraint->signature->{$idx}; |
121 | return unless $this->equals($that); |
122 | } |
123 | |
124 | if($self->has_optional_signature) { |
125 | foreach my $idx (keys %{$self->optional_signature}) { |
126 | my $this = $self->optional_signature->{$idx}; |
127 | my $that = $compared_type_constraint->optional_signature->{$idx}; |
128 | return unless $this->equals($that); |
129 | } |
130 | } |
131 | |
132 | return 1; |
133 | } |
134 | |
9a491c80 |
135 | |
9a491c80 |
136 | |
137 | =head1 AUTHOR |
138 | |
139 | John James Napiorkowski <jjnapiork@cpan.org> |
140 | |
141 | =head1 LICENSE |
142 | |
143 | You may distribute this code under the same terms as Perl itself. |
144 | |
145 | =cut |
146 | |
147 | no Moose; 1; |