separation of concerns is good
[gitmo/MooseX-Types-Structured.git] / lib / MooseX / Meta / TypeConstraint / Structured / Positional.pm
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;