1 package ## Hide from PAUSE
2 MooseX::Meta::TypeConstraint::Dependent;
5 use Moose::Util::TypeConstraints ();
6 use MooseX::Meta::TypeCoercion::Dependent;
7 use Devel::PartialDump;
8 extends 'Moose::Meta::TypeConstraint';
12 MooseX::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints.
16 see L<MooseX::Types::Dependent> for examples and details of how to use dependent
17 types. This class is a subclass of L<Moose::Meta::TypeConstraint> which
18 provides the gut functionality to enable dependent type constraints.
22 This class defines the following attributes.
24 =head2 dependent_type_constraint
26 The type constraint whose validity is being made dependent on a value that is a
27 L</constraining_type_constraint>
31 has 'dependent_type_constraint' => (
34 predicate=>'has_dependent_type_constraint',
36 check_dependent=>'check',
37 get_message_dependent=>'get_message',
41 =head2 constraining_type_constraint
43 This is a type constraint which defines what kind of value is allowed to be the
44 constraining value of the depending type.
48 has 'constraining_type_constraint' => (
51 predicate=>'has_constraining_type_constraint',
53 check_constraining=>'check',
54 get_message_constraining=>'get_message',
58 =head2 comparison_callback
60 This is a callback which returns a boolean value. It get's passed the value
61 L</constraining_type_constraint> validates as well as the check value.
63 This callback is executed in addition to anything you put into a 'where' clause.
64 However, the 'where' clause only get's the check value.
66 Exercise some sanity, this should be limited to actual comparision operations,
67 not as a sneaky way to mess with the constraining value.
69 This should return a Bool, suitable for ->check (That is true for valid, false
74 has 'comparison_callback' => (
77 predicate=>'has_comparison_callback',
80 =head2 constraint_generator
82 A subref or closure that contains the way we validate incoming values against
83 a set of type constraints.
87 has 'constraint_generator' => (
90 predicate=>'has_constraint_generator',
96 This class defines the following methods.
100 Initialization stuff.
104 around 'new' => sub {
105 my ($new, $class, @args) = @_;
106 my $self = $class->$new(@args);
107 $self->coercion(MooseX::Meta::TypeCoercion::Dependent->new(
108 type_constraint => $self,
115 We intercept validate in order to custom process the message.
119 override 'validate' => sub {
120 my ($self, @args) = @_;
121 my $compiled_type_constraint = $self->_compiled_type_constraint;
122 my $message = bless {message=>undef}, 'MooseX::Types::Dependent::Message';
123 my $result = $compiled_type_constraint->(@args, $message);
128 my $args = Devel::PartialDump::dump(@args);
129 if(my $message = $message->{message}) {
130 return $self->get_message("$args, Internal Validation Error is: $message");
132 return $self->get_message($args);
137 =head2 generate_constraint_for ($type_constraints)
139 Given some type constraints, use them to generate validation rules for an ref
140 of values (to be passed at check time)
144 sub generate_constraint_for {
145 my ($self, $callback) = @_;
147 my $dependent_pair = shift @_;
148 my ($dependent, $constraining) = @$dependent_pair;
150 ## First need to test the bits
151 unless($self->check_dependent($dependent)) {
152 $_[0]->{message} = $self->get_message_dependent($dependent)
157 unless($self->check_constraining($constraining)) {
158 $_[0]->{message} = $self->get_message_constraining($constraining)
163 my $constraint_generator = $self->constraint_generator;
164 return $constraint_generator->(
172 =head2 parameterize ($dependent, $callback, $constraining)
174 Given a ref of type constraints, create a structured type.
179 my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
180 my $class = ref $self;
181 my $name = $self->_generate_subtype_name($dependent_tc, $callback, $constraining_tc);
182 my $constraint_generator = $self->__infer_constraint_generator;
187 dependent_type_constraint=>$dependent_tc,
188 comparison_callback=>$callback,
189 constraint_generator => $constraint_generator,
190 constraining_type_constraint => $constraining_tc,
194 =head2 _generate_subtype_name
196 Returns a name for the dependent type that should be unique
200 sub _generate_subtype_name {
201 my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
203 "%s_depends_on_%s_via_%s",
204 $dependent_tc, $constraining_tc, $callback,
208 =head2 __infer_constraint_generator
210 This returns a CODEREF which generates a suitable constraint generator. Not
211 user servicable, you'll never call this directly.
213 TBD, this is definitely going to need some work. Cargo culted from some
214 code I saw in Moose::Meta::TypeConstraint::Parameterized or similar. I
215 Don't think I need this, since Dependent types require parameters, so
216 will always have a constrain generator.
220 sub __infer_constraint_generator {
222 if($self->has_constraint_generator) {
223 return $self->constraint_generator;
225 warn "I'm doing the questionable infer generator thing";
227 ## I'm not sure about this stuff but everything seems to work
231 $self->comparison_callback,
232 $self->constraining_type_constraint,
235 $self->constraint->($merged_tc, @_);
240 =head2 compile_type_constraint
242 hook into compile_type_constraint so we can set the correct validation rules.
246 around 'compile_type_constraint' => sub {
247 my ($compile_type_constraint, $self) = @_;
249 if($self->has_comparison_callback &&
250 $self->has_constraining_type_constraint) {
251 my $generated_constraint = $self->generate_constraint_for(
252 $self->comparison_callback,
254 $self->_set_constraint($generated_constraint);
257 return $self->$compile_type_constraint;
260 =head2 create_child_type
262 modifier to make sure we get the constraint_generator
266 around 'create_child_type' => sub {
267 my ($create_child_type, $self, %opts) = @_;
268 return $self->$create_child_type(
270 constraint_generator => $self->__infer_constraint_generator,
280 Override the base class behavior.
285 my ( $self, $type_or_name ) = @_;
286 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
288 return unless $other->isa(__PACKAGE__);
291 $self->type_constraints_equals($other)
293 $self->parent->equals( $other->parent )
297 =head2 type_constraints_equals
299 Checks to see if the internal type contraints are equal.
303 sub type_constraints_equals {
304 my ($self, $other) = @_;
305 my @self_type_constraints = @{$self->type_constraints||[]};
306 my @other_type_constraints = @{$other->type_constraints||[]};
308 ## Incoming ay be either arrayref or hashref, need top compare both
309 while(@self_type_constraints) {
310 my $self_type_constraint = shift @self_type_constraints;
311 my $other_type_constraint = shift @other_type_constraints
312 || return; ## $other needs the same number of children.
314 if( ref $self_type_constraint) {
315 $self_type_constraint->equals($other_type_constraint)
316 || return; ## type constraints obviously need top be equal
318 $self_type_constraint eq $other_type_constraint
319 || return; ## strings should be equal
324 return 1; ##If we get this far, everything is good.
329 Give you a better peek into what's causing the error.
333 around 'get_message' => sub {
334 my ($get_message, $self, $value) = @_;
335 return $self->$get_message($value);
340 The following modules or resources may be of interest.
342 L<Moose>, L<Moose::Meta::TypeConstraint>
346 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
348 =head1 COPYRIGHT & LICENSE
350 This program is free software; you can redistribute it and/or modify
351 it under the same terms as Perl itself.
355 __PACKAGE__->meta->make_immutable;