Commit | Line | Data |
65748864 |
1 | package MooseX::Meta::TypeConstraint::Structured; |
2 | |
3 | use 5.8.8; ## Minimum tested Perl Version |
4 | use Moose; |
5 | use Moose::Util::TypeConstraints; |
6 | |
7 | extends 'Moose::Meta::TypeConstraint'; |
8 | |
9 | our $AUTHORITY = 'cpan:JJNAPIORK'; |
10 | |
11 | =head1 NAME |
12 | |
13 | MooseX::Meta::TypeConstraint::Structured - Structured Type Constraints |
14 | |
15 | =head1 VERSION |
16 | |
17 | 0.01 |
18 | |
19 | =cut |
20 | |
21 | our $VERSION = '0.01'; |
22 | |
23 | =head1 DESCRIPTION |
24 | |
25 | Structured type constraints let you assign an internal pattern of type |
26 | constraints to a 'container' constraint. The goal is to make it easier to |
27 | declare constraints like "ArrayRef[Int, Int, Str]" where the constraint is an |
28 | ArrayRef of three elements and the internal constraint on the three is Int, Int |
29 | and Str. |
30 | |
8b276dd4 |
31 | =head1 SUBTYPES |
65748864 |
32 | |
8b276dd4 |
33 | The following subtypes and coercions are defined in this class. |
65748864 |
34 | |
8b276dd4 |
35 | =head2 MooseX::Meta::TypeConstraint::Structured::Signature |
65748864 |
36 | |
8b276dd4 |
37 | This is a type constraint to normalize the incoming L</signature>. |
65748864 |
38 | |
39 | =cut |
40 | |
bc64165b |
41 | subtype 'MooseX::Meta::TypeConstraint::Structured::Signature', |
42 | as 'HashRef[Object]', |
43 | where { |
44 | my %signature = %$_; |
45 | foreach my $key (keys %signature) { |
46 | $signature{$key}->isa('Moose::Meta::TypeConstraint'); |
47 | } 1; |
48 | }; |
49 | |
50 | coerce 'MooseX::Meta::TypeConstraint::Structured::Signature', |
51 | from 'ArrayRef[Object]', |
52 | via { |
53 | my @signature = @$_; |
54 | my %hashed_signature = map { $_ => $signature[$_] } 0..$#signature; |
55 | \%hashed_signature; |
56 | }; |
57 | |
8b276dd4 |
58 | =head1 ATTRIBUTES |
59 | |
60 | This class defines the following attributes. |
61 | |
62 | =head2 signature |
63 | |
64 | This is a signature of internal contraints for the contents of the outer |
65 | contraint container. |
66 | |
67 | =cut |
68 | |
65748864 |
69 | has 'signature' => ( |
70 | is=>'ro', |
bc64165b |
71 | isa=>'MooseX::Meta::TypeConstraint::Structured::Signature', |
72 | coerce=>1, |
65748864 |
73 | required=>1, |
74 | ); |
75 | |
76 | =head1 METHODS |
77 | |
78 | This class defines the following methods. |
79 | |
80 | =head2 _normalize_args |
81 | |
bc64165b |
82 | Get arguments into a known state or die trying. Ideally we try to make this |
83 | into a HashRef so we can match it up with the L</signature> HashRef. |
65748864 |
84 | |
85 | =cut |
86 | |
87 | sub _normalize_args { |
88 | my ($self, $args) = @_; |
bc64165b |
89 | if(defined $args) { |
90 | if(ref $args eq 'ARRAY') { |
91 | return map { $_ => $args->[$_] } (0..$#$args); |
92 | } elsif (ref $args eq 'HASH') { |
93 | return %$args; |
94 | } else { |
95 | confess 'Signature must be a reference'; |
96 | } |
65748864 |
97 | } else { |
bc64165b |
98 | confess 'Signature cannot be empty'; |
65748864 |
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 { |
bc64165b |
111 | my %args = $self->_normalize_args(shift); |
112 | foreach my $idx (keys %{$self->signature}) { |
113 | my $type_constraint = $self->signature->{$idx}; |
114 | if(my $error = $type_constraint->validate($args{$idx})) { |
65748864 |
115 | confess $error; |
116 | } |
117 | } 1; |
118 | }; |
119 | } |
120 | |
bc64165b |
121 | =head2 equals |
122 | |
123 | modifier to make sure equals descends into the L</signature> |
124 | |
125 | =cut |
126 | |
127 | around 'equals' => sub { |
128 | my ($equals, $self, $compared_type_constraint) = @_; |
129 | |
130 | ## Make sure we are comparing typeconstraints of the same base class |
131 | return unless $compared_type_constraint->isa(__PACKAGE__); |
132 | |
133 | ## Make sure the base equals is also good |
134 | return unless $self->$equals($compared_type_constraint); |
135 | |
136 | ## Make sure the signatures match |
137 | return unless $self->signature_equals($compared_type_constraint); |
138 | |
139 | ## If we get this far, the two are equal |
140 | return 1; |
141 | }; |
142 | |
143 | =head2 signature_equals |
144 | |
145 | Check that the signature equals another signature. |
146 | |
147 | =cut |
148 | |
149 | sub signature_equals { |
150 | my ($self, $compared_type_constraint) = @_; |
151 | |
152 | foreach my $idx (keys %{$self->signature}) { |
153 | my $this = $self->signature->{$idx}; |
154 | my $that = $compared_type_constraint->signature->{$idx}; |
155 | return unless $this->equals($that); |
156 | } |
157 | |
158 | return 1; |
159 | } |
160 | |
65748864 |
161 | =head1 AUTHOR |
162 | |
163 | John James Napiorkowski <jjnapiork@cpan.org> |
164 | |
165 | =head1 LICENSE |
166 | |
167 | You may distribute this code under the same terms as Perl itself. |
168 | |
169 | =cut |
170 | |
171 | no Moose; 1; |