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