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