1 package ## Hide from PAUSE
2 MooseX::Dependent::Meta::TypeConstraint::Dependent;
5 use Moose::Util::TypeConstraints ();
6 use Scalar::Util qw(blessed);
8 extends 'Moose::Meta::TypeConstraint';
12 MooseX::Dependent::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints.
16 see L<MooseX::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 parent_type_constraint
26 The type constraint whose validity is being made dependent.
30 has 'parent_type_constraint' => (
34 Moose::Util::TypeConstraints::find_type_constraint("Any");
39 =head2 constraining_value_type_constraint
41 This is a type constraint which defines what kind of value is allowed to be the
42 constraining value of the dependent type.
46 has 'constraining_value_type_constraint' => (
50 Moose::Util::TypeConstraints::find_type_constraint("Any");
55 =head2 constraining_value
57 This is the actual value that constraints the L</parent_type_constraint>
61 has 'constraining_value' => (
63 predicate=>'has_constraining_value',
66 =head2 constraint_generator
68 A subref or closure that contains the way we validate incoming values against
69 a set of type constraints.
72 has 'constraint_generator' => (
75 predicate=>'has_constraint_generator',
81 This class defines the following methods.
85 We intercept validate in order to custom process the message.
87 override 'validate' => sub {
88 my ($self, @args) = @_;
89 my $compiled_type_constraint = $self->_compiled_type_constraint;
90 my $message = bless {message=>undef}, 'MooseX::Types::Dependent::Message';
91 my $result = $compiled_type_constraint->(@args, $message);
96 my $args = Devel::PartialDump::dump(@args);
97 if(my $message = $message->{message}) {
98 return $self->get_message("$args, Internal Validation Error is: $message");
100 return $self->get_message($args);
105 =head2 generate_constraint_for ($type_constraints)
107 Given some type constraints, use them to generate validation rules for an ref
108 of values (to be passed at check time)
111 sub generate_constraint_for {
112 my ($self, $callback) = @_;
114 my $dependent_pair = shift @_;
115 my ($dependent, $constraining) = @$dependent_pair;
117 ## First need to test the bits
118 unless($self->check_dependent($dependent)) {
119 $_[0]->{message} = $self->get_message_dependent($dependent)
124 unless($self->check_constraining($constraining)) {
125 $_[0]->{message} = $self->get_message_constraining($constraining)
130 my $constraint_generator = $self->constraint_generator;
131 return $constraint_generator->(
139 =head2 parameterize (@args)
141 Given a ref of type constraints, create a structured type.
147 my $class = ref $self;
149 if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
151 my $arg2 = shift @_ || $self->constraining_value_type_constraint;
153 Moose->throw_error("$arg2 is not a type constraint")
154 unless $arg2->isa('Moose::Meta::TypeConstraint');
156 Moose->throw_error('Too Many Args! Two are allowed.') if @_;
159 name => $self->_generate_subtype_name($arg1, $arg2),
161 constraint => $self->constraint,
162 parent_type_constraint=>$arg1,
163 constraining_value_type_constraint => $arg2,
167 Moose->throw_error("$self already has a constraining value.") if
168 $self->has_constraining_value;
171 ## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}]
174 if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) {
184 ## TODO: Is there a use case for parameterizing null or undef?
185 Moose->throw_error('Cannot Parameterize null values.');
188 if(my $err = $self->constraining_value_type_constraint->validate($args)) {
189 Moose->throw_error($err);
191 ## TODO memorize or do a registry lookup on the name as an optimization
193 name => $self->name."[$args]",
195 constraint => $self->constraint,
196 constraining_value => $args,
197 parent_type_constraint=>$self->parent_type_constraint,
198 constraining_value_type_constraint => $self->constraining_value_type_constraint,
204 =head2 _generate_subtype_name
206 Returns a name for the dependent type that should be unique
210 sub _generate_subtype_name {
211 my ($self, $parent_tc, $constraining_tc) = @_;
214 $parent_tc, $constraining_tc,
218 =head2 create_child_type
220 modifier to make sure we get the constraint_generator
224 around 'create_child_type' => sub {
225 my ($create_child_type, $self, %opts) = @_;
226 if($self->has_constraining_value) {
227 $opts{constraining_value} = $self->constraining_value;
229 return $self->$create_child_type(
232 parent_type_constraint=>$self->parent_type_constraint,
233 constraining_value_type_constraint => $self->constraining_value_type_constraint,
237 =head2 equals ($type_constraint)
239 Override the base class behavior so that a dependent type equal both the parent
240 type and the overall dependent container. This behavior may change if we can
241 figure out what a dependent type is (multiply inheritance or a role...)
245 around 'equals' => sub {
246 my ( $equals, $self, $type_or_name ) = @_;
248 my $other = defined $type_or_name ?
249 Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
250 Moose->throw_error("Can't call $self ->equals without a parameter");
252 Moose->throw_error("$type_or_name is not a registered Type")
255 if(my $parent = $other->parent) {
256 return $self->$equals($other)
257 || $self->parent->equals($parent);
259 return $self->$equals($other);
263 around 'is_subtype_of' => sub {
264 my ( $is_subtype_of, $self, $type_or_name ) = @_;
266 my $other = defined $type_or_name ?
267 Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
268 Moose->throw_error("Can't call $self ->equals without a parameter");
270 Moose->throw_error("$type_or_name is not a registered Type")
273 return $self->$is_subtype_of($other)
274 || $self->parent_type_constraint->is_subtype_of($other);
279 my ($self, @args) = @_;
280 return ($self->equals(@args) ||
281 $self->is_subtype_of(@args));
284 around 'check' => sub {
285 my ($check, $self, @args) = @_;
286 return $self->parent_type_constraint->check(@args) && $self->$check(@args)
289 around 'validate' => sub {
290 my ($validate, $self, @args) = @_;
291 return $self->parent_type_constraint->validate(@args) || $self->$validate(@args);
294 around '_compiled_type_constraint' => sub {
295 my ($method, $self, @args) = @_;
296 my $coderef = $self->$method(@args);
297 my @extra_args = $self->has_constraining_value ? $self->constraining_value : ();
300 $coderef->(@local_args, @extra_args);
306 Give you a better peek into what's causing the error.
308 around 'get_message' => sub {
309 my ($get_message, $self, $value) = @_;
310 return $self->$get_message($value);
315 The following modules or resources may be of interest.
317 L<Moose>, L<Moose::Meta::TypeConstraint>
321 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
323 =head1 COPYRIGHT & LICENSE
325 This program is free software; you can redistribute it and/or modify
326 it under the same terms as Perl itself.
330 __PACKAGE__->meta->make_immutable(inline_constructor => 0);