1 package ## Hide from PAUSE
2 MooseX::Meta::TypeConstraint::Parameterizable;
5 use Moose::Util::TypeConstraints ();
6 use MooseX::Meta::TypeCoercion::Parameterizable;
7 use Scalar::Util qw(blessed);
11 extends 'Moose::Meta::TypeConstraint';
15 MooseX::Meta::TypeConstraint::Parameterizable - Metaclass for Parameterizable type constraints.
19 see L<MooseX::Parameterizable::Types> for 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::Meta::TypeCoercion::Parameterizable->new(type_constraint => $self);
92 $self->coercion($coercion);
96 =head2 parameterize (@args)
98 Given a ref of type constraints, create a parameterized constraint
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,
198 message => $self->message,
201 ## TODO This is probably going to have to go away (too many things added to the registry)
202 ##Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
203 return $type_constraint;
209 =head2 _generate_subtype_name
211 Returns a name for the parameterizable type that should be unique
215 sub _generate_subtype_name {
216 my ($self, $parent_tc, $constraining_tc) = @_;
219 $parent_tc, $constraining_tc,
223 =head2 create_child_type
225 modifier to make sure we get the constraint_generator
229 around 'create_child_type' => sub {
230 my ($create_child_type, $self, %opts) = @_;
231 if($self->has_constraining_value) {
232 $opts{constraining_value} = $self->constraining_value;
234 return $self->$create_child_type(
237 parent_type_constraint=>$self->parent_type_constraint,
238 constraining_value_type_constraint => $self->constraining_value_type_constraint,
242 =head2 equals ($type_constraint)
244 Override the base class behavior so that a parameterizable type equal both the parent
245 type and the overall parameterizable container. This behavior may change if we can
246 figure out what a parameterizable type is (multiply inheritance or a role...)
250 around 'equals' => sub {
251 my ( $equals, $self, $type_or_name ) = @_;
253 my $other = defined $type_or_name ?
254 Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
255 Moose->throw_error("Can't call $self ->equals without a parameter");
257 Moose->throw_error("$type_or_name is not a registered Type")
260 if(my $parent = $other->parent) {
261 return $self->$equals($other)
262 || $self->parent->equals($parent);
264 return $self->$equals($other);
270 Method modifier to make sure we match on subtype for both the parameterizable type
271 as well as the type being made parameterizable
275 around 'is_subtype_of' => sub {
276 my ( $is_subtype_of, $self, $type_or_name ) = @_;
278 my $other = defined $type_or_name ?
279 Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
280 Moose->throw_error("Can't call $self ->equals without a parameter");
282 Moose->throw_error("$type_or_name is not a registered Type")
285 return $self->$is_subtype_of($other)
286 || $self->parent_type_constraint->is_subtype_of($other);
292 As with 'is_subtype_of', we need to dual dispatch the method request
296 around 'check' => sub {
297 my ($check, $self, @args) = @_;
299 $self->parent_type_constraint->check(@args) &&
306 As with 'is_subtype_of', we need to dual dispatch the method request
310 around 'validate' => sub {
311 my ($validate, $self, @args) = @_;
313 $self->parent_type_constraint->validate(@args) ||
314 $self->$validate(@args)
318 =head2 _compiled_type_constraint
320 modify this method so that we pass along the constraining value to the constraint
321 coderef and also throw the correct error message if the constraining value does
322 not match it's requirement.
326 around '_compiled_type_constraint' => sub {
327 my ($method, $self, @args) = @_;
328 my $coderef = $self->$method(@args);
330 if($self->has_constraining_value) {
331 $constraining = $self->constraining_value;
336 if(my $err = $self->constraining_value_type_constraint->validate($constraining)) {
337 Moose->throw_error($err);
339 $coderef->(@local_args, $constraining);
345 More method modification to support dispatch coerce to a parent.
349 around 'coerce' => sub {
350 my ($coerce, $self, @args) = @_;
352 if($self->has_constraining_value) {
353 push @args, $self->constraining_value;
354 if(@{$self->coercion->type_coercion_map}) {
355 my $coercion = $self->coercion;
356 my $coerced = $self->$coerce(@args);
357 if(defined $coerced) {
360 my $parent = $self->parent;
361 return $parent->coerce(@args);
364 my $parent = $self->parent;
365 return $parent->coerce(@args);
369 return $self->$coerce(@args);
376 Give you a better peek into what's causing the error.
378 around 'get_message' => sub {
379 my ($get_message, $self, $value) = @_;
380 return $self->$get_message($value);
385 The following modules or resources may be of interest.
387 L<Moose>, L<Moose::Meta::TypeConstraint>
391 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
393 =head1 COPYRIGHT & LICENSE
395 This program is free software; you can redistribute it and/or modify
396 it under the same terms as Perl itself.
400 __PACKAGE__->meta->make_immutable(inline_constructor => 0);