From: John Napiorkowski Date: Thu, 23 Oct 2008 15:45:50 +0000 (+0000) Subject: changed the way subtypes are made so that we delegate the job to the actual type... X-Git-Tag: 0.60~17^2~1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9ceb576e49f52788851a510d4203b78f87443ea3;p=gitmo%2FMoose.git changed the way subtypes are made so that we delegate the job to the actual type constraint parent, rather than have a bunch of exceptions in M:U:Constraints. This will allow up to properly subtype Moose::Meta::Constraint in the MooseX namespace. Added a test to show the bug this code is trying to solve --- diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index 7837234..05a3f44 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -246,6 +246,12 @@ sub _collect_all_parents { return @parents; } +sub create_childtype { + my ($self, %opts) = @_; + my $class = ref $self; + return $class->new(%opts, parent => $self); +} + ## this should get deprecated actually ... sub union { Carp::croak "DEPRECATED" } @@ -347,6 +353,8 @@ Returns true if this type has a parent type. =item B +=item B + =back =head2 DEPRECATED METHOD diff --git a/lib/Moose/Meta/TypeConstraint/Parameterized.pm b/lib/Moose/Meta/TypeConstraint/Parameterized.pm index c6c52e7..ce4ecd2 100644 --- a/lib/Moose/Meta/TypeConstraint/Parameterized.pm +++ b/lib/Moose/Meta/TypeConstraint/Parameterized.pm @@ -56,6 +56,17 @@ sub compile_type_constraint { . $self->parent->name . " doesn't subtype or coerce from a parameterizable type."); } +sub create_childtype { + my ($self, %opts) = @_; + + return Moose::Meta::TypeConstraint->new(%opts, parent => $self); + + return $self->SUPER::create_subtype( + %opts, + type_parameter=>$self->type_parameter, + ); +} + 1; __END__ @@ -81,6 +92,8 @@ Moose::Meta::TypeConstraint::Parameterized - Higher Order type constraints for M =item B +=item B + =back =head1 BUGS diff --git a/lib/Moose/Meta/TypeConstraint/Union.pm b/lib/Moose/Meta/TypeConstraint/Union.pm index 77a6917..c9d3f42 100644 --- a/lib/Moose/Meta/TypeConstraint/Union.pm +++ b/lib/Moose/Meta/TypeConstraint/Union.pm @@ -100,6 +100,28 @@ sub is_subtype_of { return 0; } +sub create_childtype { + my ($self, %opts) = @_; + my $class = ref $self; + my $constraint = Moose::Meta::TypeConstraint->new(%opts, parent => $self); + + # if we have a type constraint union, and no + # type check, this means we are just aliasing + # the union constraint, which means we need to + # handle this differently. + # - SL + if ( + not(defined $opts{constraint}) + && $self->has_coercion + ) { + $constraint->coercion(Moose::Meta::TypeCoercion::Union->new( + type_constraint => $self, + )); + } + + return $constraint; +} + 1; __END__ @@ -182,6 +204,8 @@ anyway. They are here for completeness. =item B +=item B + =back =head1 BUGS diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index a9c9310..d361872 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -373,40 +373,41 @@ sub _create_type_constraint ($$$;$$) { . $pkg_defined_in ) if defined $type; } - - my $class = "Moose::Meta::TypeConstraint"; - - # FIXME should probably not be a special case - if ( defined $parent and $parent = find_or_parse_type_constraint($parent) ) { - $class = "Moose::Meta::TypeConstraint::Parameterizable" - if $parent->isa("Moose::Meta::TypeConstraint::Parameterizable"); - } - - my $constraint = $class->new( - name => $name || '__ANON__', + + ## Here are the basic options we will use to create the constraint. These + ## may be altered depending on the parent type, etc. + + my %opts = ( + name => $name || '__ANON__', package_defined_in => $pkg_defined_in, - ($parent ? (parent => $parent ) : ()), ($check ? (constraint => $check) : ()), ($message ? (message => $message) : ()), ($optimized ? (optimized => $optimized) : ()), ); - - # NOTE: - # if we have a type constraint union, and no - # type check, this means we are just aliasing - # the union constraint, which means we need to - # handle this differently. - # - SL - if (not(defined $check) - && $parent->isa('Moose::Meta::TypeConstraint::Union') - && $parent->has_coercion - ){ - $constraint->coercion(Moose::Meta::TypeCoercion::Union->new( - type_constraint => $parent - )); + + ## If we have a parent we make sure to instantiate this new type constraint + ## as a subclass of the parents meta class. We need to see if the $parent + ## is already a blessed TC or if we need to go make it based on it's name + + my $constraint; + + if( + defined $parent + and $parent = blessed $parent ? $parent:find_or_parse_type_constraint($parent) + ) { + ## creating the child is a job we delegate to the parent, since each + ## parent may have local customization needs to influence it's child. + $constraint = $parent->create_childtype(%opts); + } else { + ## If for some reason the above couldn't create a type constraint, let's + ## make sure to create something. + $constraint = Moose::Meta::TypeConstraint->new(%opts); } + ## Unless we have a request to make an anonynmous constraint, let's add it + ## to the $REGISTRY so that it gets cached for quicker lookups next time + $REGISTRY->add_type_constraint($constraint) if defined $name; diff --git a/t/040_type_constraints/016_subtyping_parameterized_types.t b/t/040_type_constraints/016_subtyping_parameterized_types.t index 444b18a..bd01271 100644 --- a/t/040_type_constraints/016_subtyping_parameterized_types.t +++ b/t/040_type_constraints/016_subtyping_parameterized_types.t @@ -26,7 +26,7 @@ lives_ok { is($p->name, 'HashRef[Int]', '... parent name is correct'); - ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); + ok($t->check({ one => 1, two => 2 }), '... validated {one=>1, two=>2} correctly'); ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly'); ok( $t->equals($t), "equals to self" ); @@ -59,7 +59,7 @@ lives_ok { is($p->name, 'HashRef[Int]', '... parent name is correct'); ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); - ok(!$t->check({ zero => 10, one => 11, two => 12 }), '... validated it correctly'); + ok(!$t->check({ zero => 10, one => 11, two => 12 }), '... validated { zero => 10, one => 11, two => 12 } correctly'); ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly'); } diff --git a/t/040_type_constraints/030-class_subtypes.t b/t/040_type_constraints/030-class_subtypes.t new file mode 100644 index 0000000..275a033 --- /dev/null +++ b/t/040_type_constraints/030-class_subtypes.t @@ -0,0 +1,57 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 16; +use Test::Exception; + +BEGIN { + use_ok('Moose::Util::TypeConstraints'); + use_ok('Moose::Meta::TypeConstraint'); +} + +## Create a subclass with a custom method + +{ + package Test::Moose::Meta::TypeConstraint::AnySubType; + use Moose; + extends 'Moose::Meta::TypeConstraint'; + + sub my_custom_method { + return 1; + } +} + +my $Int = Moose::Util::TypeConstraints::find_type_constraint('Int'); +ok $Int, 'Got a good type contstraint'; + +my $parent = Test::Moose::Meta::TypeConstraint::AnySubType->new({ + name => "Test::Moose::Meta::TypeConstraint::AnySubType" , + parent => $Int, +}); + +ok $parent, 'Created type constraint'; +ok $parent->check(1), 'Correctly passed'; +ok ! $parent->check('a'), 'correctly failed'; +ok $parent->my_custom_method, 'found the custom method'; + +my $subtype1 = Moose::Util::TypeConstraints::subtype 'another_subtype', + as $parent; + +ok $subtype1, 'Created type constraint'; +ok $subtype1->check(1), 'Correctly passed'; +ok ! $subtype1->check('a'), 'correctly failed'; +ok $subtype1->my_custom_method, 'found the custom method'; + + +my $subtype2 = Moose::Util::TypeConstraints::subtype 'another_subtype', + as $subtype1, + where { $_ < 10 }; + +ok $subtype2, 'Created type constraint'; +ok $subtype2->check(1), 'Correctly passed'; +ok ! $subtype2->check('a'), 'correctly failed'; +ok ! $subtype2->check(100), 'correctly failed'; + +ok $subtype2->my_custom_method, 'found the custom method'; \ No newline at end of file