Commit | Line | Data |
a30fa891 |
1 | package MooseX::Meta::TypeConstraint::Structured; |
2 | |
3 | use Moose; |
4 | use Moose::Util::TypeConstraints (); |
16aea7bf |
5 | use MooseX::Meta::TypeCoercion::Structured; |
a30fa891 |
6 | extends 'Moose::Meta::TypeConstraint'; |
7 | |
8 | =head1 NAME |
9 | |
10 | MooseX::Meta::TypeConstraint::Structured - Structured type constraints. |
11 | |
12 | =head1 DESCRIPTION |
13 | |
14 | A structure is a set of L<Moose::Meta::TypeConstraint> that are 'aggregated' in |
15 | such a way as that they are all applied to an incoming list of arguments. The |
16 | idea here is that a Type Constraint could be something like, "An Int followed by |
17 | an Int and then a Str" and that this could be done so with a declaration like: |
18 | |
19 | Tuple[Int,Int,Str]; ## Example syntax |
20 | |
21 | So a structure is a list of Type constraints (the "Int,Int,Str" in the above |
22 | example) which are intended to function together. |
23 | |
24 | =head1 ATTRIBUTES |
25 | |
26 | This class defines the following attributes. |
27 | |
28 | =head2 type_constraints |
29 | |
30 | A list of L<Moose::Meta::TypeConstraint> objects. |
31 | |
32 | =cut |
33 | |
34 | has 'type_constraints' => ( |
35 | is=>'ro', |
36 | isa=>'Ref', |
37 | predicate=>'has_type_constraints', |
38 | ); |
39 | |
40 | =head2 constraint_generator |
41 | |
42 | A subref or closure that contains the way we validate incoming values against |
43 | a set of type constraints. |
44 | |
45 | =cut |
46 | |
47 | has 'constraint_generator' => (is=>'ro', isa=>'CodeRef'); |
48 | |
49 | =head1 METHODS |
50 | |
51 | This class defines the following methods. |
52 | |
16aea7bf |
53 | =head2 new |
54 | |
55 | Initialization stuff. |
56 | |
57 | =cut |
58 | |
59 | around 'new' => sub { |
60 | my ($new, $class, @args) = @_; |
61 | my $self = $class->$new(@args); |
62 | $self->coercion(MooseX::Meta::TypeCoercion::Structured->new( |
63 | type_constraint => $self, |
64 | )); |
65 | return $self; |
66 | }; |
67 | |
a30fa891 |
68 | =head2 generate_constraint_for ($type_constraints) |
69 | |
70 | Given some type constraints, use them to generate validation rules for an ref |
71 | of values (to be passed at check time) |
72 | |
73 | =cut |
74 | |
75 | sub generate_constraint_for { |
76 | my ($self, $type_constraints) = @_; |
77 | return sub { |
78 | my $constraint_generator = $self->constraint_generator; |
79 | return $constraint_generator->($type_constraints, @_); |
80 | }; |
81 | } |
82 | |
83 | =head2 parameterize (@type_constraints) |
84 | |
85 | Given a ref of type constraints, create a structured type. |
86 | |
87 | =cut |
88 | |
89 | sub parameterize { |
16aea7bf |
90 | my ($self, @type_constraints) = @_; |
91 | my $class = ref $self; |
a30fa891 |
92 | my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']'; |
67a8bc04 |
93 | |
16aea7bf |
94 | return $class->new( |
a30fa891 |
95 | name => $name, |
96 | parent => $self, |
97 | type_constraints => \@type_constraints, |
67a8bc04 |
98 | constraint_generator => $self->constraint_generator || sub { |
99 | my $tc = shift @_; |
100 | my $merged_tc = [@$tc, @{$self->parent->type_constraints}]; |
101 | $self->constraint->($merged_tc, @_); |
102 | }, |
a30fa891 |
103 | ); |
104 | } |
105 | |
106 | =head2 compile_type_constraint |
107 | |
108 | hook into compile_type_constraint so we can set the correct validation rules. |
109 | |
110 | =cut |
111 | |
112 | around 'compile_type_constraint' => sub { |
113 | my ($compile_type_constraint, $self, @args) = @_; |
114 | |
115 | if($self->has_type_constraints) { |
116 | my $type_constraints = $self->type_constraints; |
117 | my $constraint = $self->generate_constraint_for($type_constraints); |
118 | $self->_set_constraint($constraint); |
119 | } |
120 | |
121 | return $self->$compile_type_constraint(@args); |
122 | }; |
123 | |
a4a88fef |
124 | =head2 create_child_type |
125 | |
126 | modifier to make sure we get the constraint_generator |
127 | |
128 | =cut |
129 | |
130 | around 'create_child_type' => sub { |
131 | my ($create_child_type, $self, %opts) = @_; |
132 | return $self->$create_child_type( |
133 | %opts, |
134 | constraint_generator => $self->constraint_generator, |
135 | ); |
136 | }; |
137 | |
138 | =head2 is_a_type_of |
139 | |
140 | =head2 is_subtype_of |
141 | |
142 | =head2 equals |
143 | |
16aea7bf |
144 | Override the base class behavior. |
145 | |
146 | =cut |
147 | |
148 | sub equals { |
149 | my ( $self, $type_or_name ) = @_; |
150 | my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); |
151 | |
152 | return unless $other->isa(__PACKAGE__); |
153 | |
154 | return ( |
155 | $self->type_constraints_equals($other) |
156 | and |
157 | $self->parent->equals( $other->parent ) |
158 | ); |
159 | } |
160 | |
161 | =head2 type_constraints_equals |
162 | |
163 | Checks to see if the internal type contraints are equal. |
164 | |
165 | =cut |
166 | |
167 | sub type_constraints_equals { |
168 | my ($self, $other) = @_; |
169 | my @self_type_constraints = @{$self->type_constraints||[]}; |
170 | my @other_type_constraints = @{$other->type_constraints||[]}; |
171 | |
172 | ## Incoming ay be either arrayref or hashref, need top compare both |
173 | while(@self_type_constraints) { |
174 | my $self_type_constraint = shift @self_type_constraints; |
175 | my $other_type_constraint = shift @other_type_constraints |
176 | || return; ## $other needs the same number of children. |
177 | |
178 | if( ref $self_type_constraint) { |
179 | $self_type_constraint->equals($other_type_constraint) |
180 | || return; ## type constraints obviously need top be equal |
181 | } else { |
182 | $self_type_constraint eq $other_type_constraint |
183 | || return; ## strings should be equal |
184 | } |
185 | |
186 | } |
187 | |
188 | return 1; ##If we get this far, everything is good. |
189 | } |
190 | |
a4a88fef |
191 | =head2 get_message |
192 | |
16aea7bf |
193 | May want to override this to set a more useful error message |
a4a88fef |
194 | |
a30fa891 |
195 | =head1 SEE ALSO |
196 | |
197 | The following modules or resources may be of interest. |
198 | |
199 | L<Moose>, L<Moose::Meta::TypeConstraint> |
200 | |
201 | =head1 AUTHOR |
202 | |
203 | John Napiorkowski, C<< <jjnapiork@cpan.org> >> |
204 | |
205 | =head1 COPYRIGHT & LICENSE |
206 | |
207 | This program is free software; you can redistribute it and/or modify |
208 | it under the same terms as Perl itself. |
209 | |
210 | =cut |
211 | |
212 | 1; |