1 package ## Hide from PAUSE
2 MooseX::Dependent::Meta::TypeConstraint::Dependent;
5 use Moose::Util::TypeConstraints ();
6 use Scalar::Util qw(blessed);
10 extends 'Moose::Meta::TypeConstraint';
14 MooseX::Dependent::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints.
18 see L<MooseX::Dependent> for examples and details of how to use dependent
19 types. This class is a subclass of L<Moose::Meta::TypeConstraint> which
20 provides the gut functionality to enable dependent type constraints.
24 This class defines the following attributes.
26 =head2 parent_type_constraint
28 The type constraint whose validity is being made dependent.
32 has 'parent_type_constraint' => (
36 Moose::Util::TypeConstraints::find_type_constraint("Any");
42 =head2 constraining_value_type_constraint
44 This is a type constraint which defines what kind of value is allowed to be the
45 constraining value of the dependent type.
49 has 'constraining_value_type_constraint' => (
53 Moose::Util::TypeConstraints::find_type_constraint("Any");
58 =head2 constraining_value
60 This is the actual value that constraints the L</parent_type_constraint>
64 has 'constraining_value' => (
66 predicate=>'has_constraining_value',
71 This class defines the following methods.
73 =head2 parameterize (@args)
75 Given a ref of type constraints, create a structured type.
81 my $class = ref $self;
83 Moose->throw_error("$self already has a constraining value.") if
84 $self->has_constraining_value;
86 if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
89 if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
90 my $arg2 = shift @_ || $self->constraining_value_type_constraint;
92 ## TODO fix this crap!
93 Moose->throw_error("$arg2 is not a type constraint")
94 unless $arg2->isa('Moose::Meta::TypeConstraint');
96 Moose->throw_error("$arg1 is not a type of: ".$self->parent_type_constraint->name)
97 unless $arg1->is_a_type_of($self->parent_type_constraint);
99 Moose->throw_error("$arg2 is not a type of: ".$self->constraining_value_type_constraint->name)
100 unless $arg2->is_a_type_of($self->constraining_value_type_constraint);
102 Moose->throw_error('Too Many Args! Two are allowed.') if @_;
104 my $name = $self->_generate_subtype_name($arg1, $arg2);
105 if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
108 my $type_constraint = $class->new(
111 constraint => $self->constraint,
112 parent_type_constraint=>$arg1,
113 constraining_value_type_constraint => $arg2,
115 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
116 return $type_constraint;
119 Moose->throw_error("$arg1 is not a type of: ".$self->constraining_value_type_constraint->name)
120 unless $arg1->is_a_type_of($self->constraining_value_type_constraint);
122 my $name = $self->_generate_subtype_name($self->parent_type_constraint, $arg1);
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=>$self->parent_type_constraint,
131 constraining_value_type_constraint => $arg1,
133 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
134 return $type_constraint;
139 ## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}]
142 if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) {
152 ## TODO: Is there a use case for parameterizing null or undef?
153 Moose->throw_error('Cannot Parameterize null values.');
156 if(my $err = $self->constraining_value_type_constraint->validate($args)) {
157 Moose->throw_error($err);
162 $sig = Digest::MD5::md5_hex(Data::Dump::dump($args));
164 my $name = $self->name."[$sig]";
165 if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
168 my $type_constraint = $class->new(
171 constraint => $self->constraint,
172 constraining_value => $args,
173 parent_type_constraint=>$self->parent_type_constraint,
174 constraining_value_type_constraint => $self->constraining_value_type_constraint,
176 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
177 return $type_constraint;
183 =head2 _generate_subtype_name
185 Returns a name for the dependent type that should be unique
189 sub _generate_subtype_name {
190 my ($self, $parent_tc, $constraining_tc) = @_;
193 $parent_tc, $constraining_tc,
197 =head2 create_child_type
199 modifier to make sure we get the constraint_generator
203 around 'create_child_type' => sub {
204 my ($create_child_type, $self, %opts) = @_;
205 if($self->has_constraining_value) {
206 $opts{constraining_value} = $self->constraining_value;
208 return $self->$create_child_type(
211 parent_type_constraint=>$self->parent_type_constraint,
212 constraining_value_type_constraint => $self->constraining_value_type_constraint,
216 =head2 equals ($type_constraint)
218 Override the base class behavior so that a dependent type equal both the parent
219 type and the overall dependent container. This behavior may change if we can
220 figure out what a dependent type is (multiply inheritance or a role...)
224 around 'equals' => sub {
225 my ( $equals, $self, $type_or_name ) = @_;
227 my $other = defined $type_or_name ?
228 Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
229 Moose->throw_error("Can't call $self ->equals without a parameter");
231 Moose->throw_error("$type_or_name is not a registered Type")
234 if(my $parent = $other->parent) {
235 return $self->$equals($other)
236 || $self->parent->equals($parent);
238 return $self->$equals($other);
242 around 'is_subtype_of' => sub {
243 my ( $is_subtype_of, $self, $type_or_name ) = @_;
245 my $other = defined $type_or_name ?
246 Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
247 Moose->throw_error("Can't call $self ->equals without a parameter");
249 Moose->throw_error("$type_or_name is not a registered Type")
252 return $self->$is_subtype_of($other)
253 || $self->parent_type_constraint->is_subtype_of($other);
258 my ($self, @args) = @_;
259 return ($self->equals(@args) ||
260 $self->is_subtype_of(@args));
263 around 'check' => sub {
264 my ($check, $self, @args) = @_;
266 $self->parent_type_constraint->check(@args) &&
271 around 'validate' => sub {
272 my ($validate, $self, @args) = @_;
274 $self->parent_type_constraint->validate(@args) ||
275 $self->$validate(@args)
279 around '_compiled_type_constraint' => sub {
280 my ($method, $self, @args) = @_;
281 my $coderef = $self->$method(@args);
283 if($self->has_constraining_value) {
284 $constraining = $self->constraining_value;
289 if(my $err = $self->constraining_value_type_constraint->validate($constraining)) {
290 Moose->throw_error($err);
292 $coderef->(@local_args, $constraining);
296 around 'coerce' => sub {
297 my ($coerce, $self, @args) = @_;
298 if($self->coercion) {
299 if(my $value = $self->$coerce(@args)) {
303 return $self->parent->coerce(@args);
308 Give you a better peek into what's causing the error.
310 around 'get_message' => sub {
311 my ($get_message, $self, $value) = @_;
312 return $self->$get_message($value);
317 The following modules or resources may be of interest.
319 L<Moose>, L<Moose::Meta::TypeConstraint>
323 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
325 =head1 COPYRIGHT & LICENSE
327 This program is free software; you can redistribute it and/or modify
328 it under the same terms as Perl itself.
332 __PACKAGE__->meta->make_immutable(inline_constructor => 0);