1 package ## Hide from PAUSE
2 MooseX::Parameterizable::Meta::TypeConstraint::Parameterizable;
5 use Moose::Util::TypeConstraints ();
6 use MooseX::Parameterizable::Meta::TypeCoercion::Parameterizable;
7 use Scalar::Util qw(blessed);
11 extends 'Moose::Meta::TypeConstraint';
15 MooseX::Parameterizable::Meta::TypeConstraint::Parameterizable - Metaclass for Parameterizable type constraints.
19 see L<MooseX::Parameterizable> for examples and details of how to use parameterizable
20 types. This class is a subclass of L<Moose::Meta::TypeConstraint> which
21 provides the gut functionality to enable parameterizable type constraints.
23 This class is not intended for public consumption. Please don't subclass it
24 or rely on it. Chances are high stuff here is going to change a lot. For
25 example, I will probably refactor this into several classes to get rid of all
26 the ugly conditionals.
30 This class defines the following attributes.
32 =head2 parent_type_constraint
34 The type constraint whose validity is being made parameterizable.
38 has 'parent_type_constraint' => (
42 Moose::Util::TypeConstraints::find_type_constraint("Any");
48 =head2 constraining_value_type_constraint
50 This is a type constraint which defines what kind of value is allowed to be the
51 constraining value of the parameterizable type.
55 has 'constraining_value_type_constraint' => (
59 Moose::Util::TypeConstraints::find_type_constraint("Any");
64 =head2 constraining_value
66 This is the actual value that constraints the L</parent_type_constraint>
70 has 'constraining_value' => (
72 predicate=>'has_constraining_value',
77 This class defines the following methods.
81 Do some post build stuff
85 ## Right now I add in the parameterizable type coercion until I can merge some Moose
89 my ($new, $class, @args) = @_;
90 my $self = $class->$new(@args);
91 my $coercion = MooseX::Parameterizable::Meta::TypeCoercion::Parameterizable->new(type_constraint => $self);
92 $self->coercion($coercion);
96 =head2 parameterize (@args)
98 Given a ref of type constraints, create a structured type.
104 my $class = ref $self;
106 Moose->throw_error("$self already has a constraining value.") if
107 $self->has_constraining_value;
109 if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
112 if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
113 my $arg2 = shift @_ || $self->constraining_value_type_constraint;
115 ## TODO fix this crap!
116 Moose->throw_error("$arg2 is not a type constraint")
117 unless $arg2->isa('Moose::Meta::TypeConstraint');
119 Moose->throw_error("$arg1 is not a type of: ".$self->parent_type_constraint->name)
120 unless $arg1->is_a_type_of($self->parent_type_constraint);
122 Moose->throw_error("$arg2 is not a type of: ".$self->constraining_value_type_constraint->name)
123 unless $arg2->is_a_type_of($self->constraining_value_type_constraint);
125 Moose->throw_error('Too Many Args! Two are allowed.') if @_;
127 my $name = $self->_generate_subtype_name($arg1, $arg2);
128 if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
131 my $type_constraint = $class->new(
134 constraint => $self->constraint,
135 parent_type_constraint=>$arg1,
136 constraining_value_type_constraint => $arg2,
138 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
139 return $type_constraint;
142 Moose->throw_error("$arg1 is not a type of: ".$self->constraining_value_type_constraint->name)
143 unless $arg1->is_a_type_of($self->constraining_value_type_constraint);
145 my $name = $self->_generate_subtype_name($self->parent_type_constraint, $arg1);
146 if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
149 my $type_constraint = $class->new(
152 constraint => $self->constraint,
153 parent_type_constraint=>$self->parent_type_constraint,
154 constraining_value_type_constraint => $arg1,
156 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
157 return $type_constraint;
162 ## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}]
165 if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) {
175 ## TODO: Is there a use case for parameterizing null or undef?
176 Moose->throw_error('Cannot Parameterize null values.');
179 if(my $err = $self->constraining_value_type_constraint->validate($args)) {
180 Moose->throw_error($err);
185 $sig = Digest::MD5::md5_hex(Data::Dump::dump($args));
187 my $name = $self->name."[$sig]";
188 if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
191 my $type_constraint = $class->new(
194 constraint => $self->constraint,
195 constraining_value => $args,
196 parent_type_constraint=>$self->parent_type_constraint,
197 constraining_value_type_constraint => $self->constraining_value_type_constraint,
200 ## TODO This is probably going to have to go away (too many things added to the registry)
201 ##Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
202 return $type_constraint;
208 =head2 _generate_subtype_name
210 Returns a name for the parameterizable type that should be unique
214 sub _generate_subtype_name {
215 my ($self, $parent_tc, $constraining_tc) = @_;
218 $parent_tc, $constraining_tc,
222 =head2 create_child_type
224 modifier to make sure we get the constraint_generator
228 around 'create_child_type' => sub {
229 my ($create_child_type, $self, %opts) = @_;
230 if($self->has_constraining_value) {
231 $opts{constraining_value} = $self->constraining_value;
233 return $self->$create_child_type(
236 parent_type_constraint=>$self->parent_type_constraint,
237 constraining_value_type_constraint => $self->constraining_value_type_constraint,
241 =head2 equals ($type_constraint)
243 Override the base class behavior so that a parameterizable type equal both the parent
244 type and the overall parameterizable container. This behavior may change if we can
245 figure out what a parameterizable type is (multiply inheritance or a role...)
249 around 'equals' => sub {
250 my ( $equals, $self, $type_or_name ) = @_;
252 my $other = defined $type_or_name ?
253 Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
254 Moose->throw_error("Can't call $self ->equals without a parameter");
256 Moose->throw_error("$type_or_name is not a registered Type")
259 if(my $parent = $other->parent) {
260 return $self->$equals($other)
261 || $self->parent->equals($parent);
263 return $self->$equals($other);
269 Method modifier to make sure we match on subtype for both the parameterizable type
270 as well as the type being made parameterizable
274 around 'is_subtype_of' => sub {
275 my ( $is_subtype_of, $self, $type_or_name ) = @_;
277 my $other = defined $type_or_name ?
278 Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
279 Moose->throw_error("Can't call $self ->equals without a parameter");
281 Moose->throw_error("$type_or_name is not a registered Type")
284 return $self->$is_subtype_of($other)
285 || $self->parent_type_constraint->is_subtype_of($other);
291 As with 'is_subtype_of', we need to dual dispatch the method request
295 around 'check' => sub {
296 my ($check, $self, @args) = @_;
298 $self->parent_type_constraint->check(@args) &&
305 As with 'is_subtype_of', we need to dual dispatch the method request
309 around 'validate' => sub {
310 my ($validate, $self, @args) = @_;
312 $self->parent_type_constraint->validate(@args) ||
313 $self->$validate(@args)
317 =head2 _compiled_type_constraint
319 modify this method so that we pass along the constraining value to the constraint
320 coderef and also throw the correct error message if the constraining value does
321 not match it's requirement.
325 around '_compiled_type_constraint' => sub {
326 my ($method, $self, @args) = @_;
327 my $coderef = $self->$method(@args);
329 if($self->has_constraining_value) {
330 $constraining = $self->constraining_value;
335 if(my $err = $self->constraining_value_type_constraint->validate($constraining)) {
336 Moose->throw_error($err);
338 $coderef->(@local_args, $constraining);
344 More method modification to support dispatch coerce to a parent.
348 around 'coerce' => sub {
349 my ($coerce, $self, @args) = @_;
351 if($self->has_constraining_value) {
352 push @args, $self->constraining_value;
353 if(@{$self->coercion->type_coercion_map}) {
354 my $coercion = $self->coercion;
355 my $coerced = $self->$coerce(@args);
356 if(defined $coerced) {
359 my $parent = $self->parent;
360 return $parent->coerce(@args);
363 my $parent = $self->parent;
364 return $parent->coerce(@args);
368 return $self->$coerce(@args);
375 Give you a better peek into what's causing the error.
377 around 'get_message' => sub {
378 my ($get_message, $self, $value) = @_;
379 return $self->$get_message($value);
384 The following modules or resources may be of interest.
386 L<Moose>, L<Moose::Meta::TypeConstraint>
390 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
392 =head1 COPYRIGHT & LICENSE
394 This program is free software; you can redistribute it and/or modify
395 it under the same terms as Perl itself.
400 ##__PACKAGE__->meta->make_immutable(inline_constructor => 0);