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
81 my ($new, $class, @args) = @_;
82 my $self = $class->$new(@args);
83 my $coercion = MooseX::Dependent::Meta::TypeCoercion::Dependent->new(type_constraint => $self);
84 $self->coercion($coercion);
88 =head2 parameterize (@args)
90 Given a ref of type constraints, create a structured type.
96 my $class = ref $self;
98 Moose->throw_error("$self already has a constraining value.") if
99 $self->has_constraining_value;
101 if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
104 if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
105 my $arg2 = shift @_ || $self->constraining_value_type_constraint;
107 ## TODO fix this crap!
108 Moose->throw_error("$arg2 is not a type constraint")
109 unless $arg2->isa('Moose::Meta::TypeConstraint');
111 Moose->throw_error("$arg1 is not a type of: ".$self->parent_type_constraint->name)
112 unless $arg1->is_a_type_of($self->parent_type_constraint);
114 Moose->throw_error("$arg2 is not a type of: ".$self->constraining_value_type_constraint->name)
115 unless $arg2->is_a_type_of($self->constraining_value_type_constraint);
117 Moose->throw_error('Too Many Args! Two are allowed.') if @_;
119 my $name = $self->_generate_subtype_name($arg1, $arg2);
120 if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
123 my $type_constraint = $class->new(
126 constraint => $self->constraint,
127 parent_type_constraint=>$arg1,
128 constraining_value_type_constraint => $arg2,
130 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
131 return $type_constraint;
134 Moose->throw_error("$arg1 is not a type of: ".$self->constraining_value_type_constraint->name)
135 unless $arg1->is_a_type_of($self->constraining_value_type_constraint);
137 my $name = $self->_generate_subtype_name($self->parent_type_constraint, $arg1);
138 if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
141 my $type_constraint = $class->new(
144 constraint => $self->constraint,
145 parent_type_constraint=>$self->parent_type_constraint,
146 constraining_value_type_constraint => $arg1,
148 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
149 return $type_constraint;
154 ## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}]
157 if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) {
167 ## TODO: Is there a use case for parameterizing null or undef?
168 Moose->throw_error('Cannot Parameterize null values.');
171 if(my $err = $self->constraining_value_type_constraint->validate($args)) {
172 Moose->throw_error($err);
177 $sig = Digest::MD5::md5_hex(Data::Dump::dump($args));
179 my $name = $self->name."[$sig]";
180 if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
183 my $type_constraint = $class->new(
186 constraint => $self->constraint,
187 constraining_value => $args,
188 parent_type_constraint=>$self->parent_type_constraint,
189 constraining_value_type_constraint => $self->constraining_value_type_constraint,
192 ## TODO This is probably going to have to go away (too many things added to the registry)
193 ##Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
194 return $type_constraint;
200 =head2 _generate_subtype_name
202 Returns a name for the dependent type that should be unique
206 sub _generate_subtype_name {
207 my ($self, $parent_tc, $constraining_tc) = @_;
210 $parent_tc, $constraining_tc,
214 =head2 create_child_type
216 modifier to make sure we get the constraint_generator
220 around 'create_child_type' => sub {
221 my ($create_child_type, $self, %opts) = @_;
222 if($self->has_constraining_value) {
223 $opts{constraining_value} = $self->constraining_value;
225 return $self->$create_child_type(
228 parent_type_constraint=>$self->parent_type_constraint,
229 constraining_value_type_constraint => $self->constraining_value_type_constraint,
233 =head2 equals ($type_constraint)
235 Override the base class behavior so that a dependent type equal both the parent
236 type and the overall dependent container. This behavior may change if we can
237 figure out what a dependent type is (multiply inheritance or a role...)
241 around 'equals' => sub {
242 my ( $equals, $self, $type_or_name ) = @_;
244 my $other = defined $type_or_name ?
245 Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
246 Moose->throw_error("Can't call $self ->equals without a parameter");
248 Moose->throw_error("$type_or_name is not a registered Type")
251 if(my $parent = $other->parent) {
252 return $self->$equals($other)
253 || $self->parent->equals($parent);
255 return $self->$equals($other);
259 around 'is_subtype_of' => sub {
260 my ( $is_subtype_of, $self, $type_or_name ) = @_;
262 my $other = defined $type_or_name ?
263 Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
264 Moose->throw_error("Can't call $self ->equals without a parameter");
266 Moose->throw_error("$type_or_name is not a registered Type")
269 return $self->$is_subtype_of($other)
270 || $self->parent_type_constraint->is_subtype_of($other);
275 my ($self, @args) = @_;
276 return ($self->equals(@args) ||
277 $self->is_subtype_of(@args));
280 around 'check' => sub {
281 my ($check, $self, @args) = @_;
283 $self->parent_type_constraint->check(@args) &&
288 around 'validate' => sub {
289 my ($validate, $self, @args) = @_;
291 $self->parent_type_constraint->validate(@args) ||
292 $self->$validate(@args)
296 around '_compiled_type_constraint' => sub {
297 my ($method, $self, @args) = @_;
298 my $coderef = $self->$method(@args);
300 if($self->has_constraining_value) {
301 $constraining = $self->constraining_value;
306 if(my $err = $self->constraining_value_type_constraint->validate($constraining)) {
307 Moose->throw_error($err);
309 $coderef->(@local_args, $constraining);
313 ## if the constraining value has been added, no way to do a coercion.
314 around 'coerce' => sub {
315 my ($coerce, $self, @args) = @_;
317 if($self->has_constraining_value) {
318 push @args, $self->constraining_value;
319 if(@{$self->coercion->type_coercion_map}) {
320 my $coercion = $self->coercion;
321 warn "coercion map found in $coercion found for $self";
322 my $coerced = $self->$coerce(@args);
323 if(defined $coerced) {
324 warn "got coerced args of ", $coerced;
327 my $parent = $self->parent;
328 warn "no coercion for $self, using $parent";
329 return $parent->coerce(@args);
332 my $parent = $self->parent;
333 #warn "no coercion for $self, using $parent";
334 return $parent->coerce(@args);
338 return $self->$coerce(@args);
345 Give you a better peek into what's causing the error.
347 around 'get_message' => sub {
348 my ($get_message, $self, $value) = @_;
349 return $self->$get_message($value);
354 The following modules or resources may be of interest.
356 L<Moose>, L<Moose::Meta::TypeConstraint>
360 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
362 =head1 COPYRIGHT & LICENSE
364 This program is free software; you can redistribute it and/or modify
365 it under the same terms as Perl itself.
370 ##__PACKAGE__->meta->make_immutable(inline_constructor => 0);