1 package ## Hide from PAUSE
2 MooseX::Dependent::Meta::TypeConstraint::Dependent;
5 use Moose::Util::TypeConstraints ();
6 use MooseX::Dependent::Meta::TypeCoercion::Dependent;
7 use Scalar::Util qw(blessed);
11 extends 'Moose::Meta::TypeConstraint';
15 MooseX::Dependent::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints.
19 see L<MooseX::Dependent> for examples and details of how to use dependent
20 types. This class is a subclass of L<Moose::Meta::TypeConstraint> which
21 provides the gut functionality to enable dependent type constraints.
25 This class defines the following attributes.
27 =head2 parent_type_constraint
29 The type constraint whose validity is being made dependent.
33 has 'parent_type_constraint' => (
37 Moose::Util::TypeConstraints::find_type_constraint("Any");
43 =head2 constraining_value_type_constraint
45 This is a type constraint which defines what kind of value is allowed to be the
46 constraining value of the dependent type.
50 has 'constraining_value_type_constraint' => (
54 Moose::Util::TypeConstraints::find_type_constraint("Any");
59 =head2 constraining_value
61 This is the actual value that constraints the L</parent_type_constraint>
65 has 'constraining_value' => (
67 predicate=>'has_constraining_value',
72 This class defines the following methods.
76 Do some post build stuff
80 ## Right now I add in the dependent type coercion until I can merge some Moose
84 my ($new, $class, @args) = @_;
85 my $self = $class->$new(@args);
86 my $coercion = MooseX::Dependent::Meta::TypeCoercion::Dependent->new(type_constraint => $self);
87 $self->coercion($coercion);
91 =head2 parameterize (@args)
93 Given a ref of type constraints, create a structured type.
99 my $class = ref $self;
101 Moose->throw_error("$self already has a constraining value.") if
102 $self->has_constraining_value;
104 if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
107 if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
108 my $arg2 = shift @_ || $self->constraining_value_type_constraint;
110 ## TODO fix this crap!
111 Moose->throw_error("$arg2 is not a type constraint")
112 unless $arg2->isa('Moose::Meta::TypeConstraint');
114 Moose->throw_error("$arg1 is not a type of: ".$self->parent_type_constraint->name)
115 unless $arg1->is_a_type_of($self->parent_type_constraint);
117 Moose->throw_error("$arg2 is not a type of: ".$self->constraining_value_type_constraint->name)
118 unless $arg2->is_a_type_of($self->constraining_value_type_constraint);
120 Moose->throw_error('Too Many Args! Two are allowed.') if @_;
122 my $name = $self->_generate_subtype_name($arg1, $arg2);
123 if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
126 my $type_constraint = $class->new(
129 constraint => $self->constraint,
130 parent_type_constraint=>$arg1,
131 constraining_value_type_constraint => $arg2,
133 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
134 return $type_constraint;
137 Moose->throw_error("$arg1 is not a type of: ".$self->constraining_value_type_constraint->name)
138 unless $arg1->is_a_type_of($self->constraining_value_type_constraint);
140 my $name = $self->_generate_subtype_name($self->parent_type_constraint, $arg1);
141 if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
144 my $type_constraint = $class->new(
147 constraint => $self->constraint,
148 parent_type_constraint=>$self->parent_type_constraint,
149 constraining_value_type_constraint => $arg1,
151 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
152 return $type_constraint;
157 ## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}]
160 if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) {
170 ## TODO: Is there a use case for parameterizing null or undef?
171 Moose->throw_error('Cannot Parameterize null values.');
174 if(my $err = $self->constraining_value_type_constraint->validate($args)) {
175 Moose->throw_error($err);
180 $sig = Digest::MD5::md5_hex(Data::Dump::dump($args));
182 my $name = $self->name."[$sig]";
183 if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
186 my $type_constraint = $class->new(
189 constraint => $self->constraint,
190 constraining_value => $args,
191 parent_type_constraint=>$self->parent_type_constraint,
192 constraining_value_type_constraint => $self->constraining_value_type_constraint,
195 ## TODO This is probably going to have to go away (too many things added to the registry)
196 ##Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
197 return $type_constraint;
203 =head2 _generate_subtype_name
205 Returns a name for the dependent type that should be unique
209 sub _generate_subtype_name {
210 my ($self, $parent_tc, $constraining_tc) = @_;
213 $parent_tc, $constraining_tc,
217 =head2 create_child_type
219 modifier to make sure we get the constraint_generator
223 around 'create_child_type' => sub {
224 my ($create_child_type, $self, %opts) = @_;
225 if($self->has_constraining_value) {
226 $opts{constraining_value} = $self->constraining_value;
228 return $self->$create_child_type(
231 parent_type_constraint=>$self->parent_type_constraint,
232 constraining_value_type_constraint => $self->constraining_value_type_constraint,
236 =head2 equals ($type_constraint)
238 Override the base class behavior so that a dependent type equal both the parent
239 type and the overall dependent container. This behavior may change if we can
240 figure out what a dependent type is (multiply inheritance or a role...)
244 around 'equals' => sub {
245 my ( $equals, $self, $type_or_name ) = @_;
247 my $other = defined $type_or_name ?
248 Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
249 Moose->throw_error("Can't call $self ->equals without a parameter");
251 Moose->throw_error("$type_or_name is not a registered Type")
254 if(my $parent = $other->parent) {
255 return $self->$equals($other)
256 || $self->parent->equals($parent);
258 return $self->$equals($other);
264 Method modifier to make sure we match on subtype for both the dependent type
265 as well as the type being made dependent
269 around 'is_subtype_of' => sub {
270 my ( $is_subtype_of, $self, $type_or_name ) = @_;
272 my $other = defined $type_or_name ?
273 Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
274 Moose->throw_error("Can't call $self ->equals without a parameter");
276 Moose->throw_error("$type_or_name is not a registered Type")
279 return $self->$is_subtype_of($other)
280 || $self->parent_type_constraint->is_subtype_of($other);
286 As with 'is_subtype_of', we need to dual dispatch the method request
290 around 'check' => sub {
291 my ($check, $self, @args) = @_;
293 $self->parent_type_constraint->check(@args) &&
300 As with 'is_subtype_of', we need to dual dispatch the method request
304 around 'validate' => sub {
305 my ($validate, $self, @args) = @_;
307 $self->parent_type_constraint->validate(@args) ||
308 $self->$validate(@args)
312 =head2 _compiled_type_constraint
314 modify this method so that we pass along the constraining value to the constraint
315 coderef and also throw the correct error message if the constraining value does
316 not match it's requirement.
320 around '_compiled_type_constraint' => sub {
321 my ($method, $self, @args) = @_;
322 my $coderef = $self->$method(@args);
324 if($self->has_constraining_value) {
325 $constraining = $self->constraining_value;
330 if(my $err = $self->constraining_value_type_constraint->validate($constraining)) {
331 Moose->throw_error($err);
333 $coderef->(@local_args, $constraining);
339 More method modification to support dispatch coerce to a parent.
343 around 'coerce' => sub {
344 my ($coerce, $self, @args) = @_;
346 if($self->has_constraining_value) {
347 push @args, $self->constraining_value;
348 if(@{$self->coercion->type_coercion_map}) {
349 my $coercion = $self->coercion;
350 my $coerced = $self->$coerce(@args);
351 if(defined $coerced) {
354 my $parent = $self->parent;
355 return $parent->coerce(@args);
358 my $parent = $self->parent;
359 return $parent->coerce(@args);
363 return $self->$coerce(@args);
370 Give you a better peek into what's causing the error.
372 around 'get_message' => sub {
373 my ($get_message, $self, $value) = @_;
374 return $self->$get_message($value);
379 The following modules or resources may be of interest.
381 L<Moose>, L<Moose::Meta::TypeConstraint>
385 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
387 =head1 COPYRIGHT & LICENSE
389 This program is free software; you can redistribute it and/or modify
390 it under the same terms as Perl itself.
395 ##__PACKAGE__->meta->make_immutable(inline_constructor => 0);