From: John Napiorkowski Date: Thu, 11 Sep 2008 16:40:16 +0000 (+0000) Subject: finished parameterized method, tests and converted Moose::Util::TypeConstraints to... X-Git-Tag: 0.58~37^2~17 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2dd0aea3321408c61af5bb851fb9ca5ad33596ca;p=gitmo%2FMoose.git finished parameterized method, tests and converted Moose::Util::TypeConstraints to use it --- diff --git a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm index 530f026..a8e32a3 100644 --- a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm +++ b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm @@ -42,20 +42,25 @@ sub _can_coerce_constraint_from { } sub parameterize { - my ($self, $args) = @_; + my ($self, @args) = @_; + + ## ugly hacking to deal with tc naming normalization issue + my ($tc_name, $contained_tc); + if (ref $args[0]) { + $contained_tc = shift @args; + $tc_name = $self->name .'['. $contained_tc->name .']'; + } else { + ($tc_name, $contained_tc) = @args; + } - unless(ref $args eq 'ARRAY') { - Moose->throw_error( - "The type constraint ".$self->name." requires it's argument to be an ArrayRef" - ); + unless($contained_tc->isa('Moose::Meta::TypeConstraint')) { + Moose->throw_error("The type parameter must be a Moose meta type"); } - my $contained_tc = find_or_create_isa_type_constraint($args->[0]); - return Moose::Meta::TypeConstraint::Parameterized->new( - name => $self->name .'['.$contained_tc->name.']', + name => $tc_name, parent => $self, - type_parameter => find_or_create_isa_type_constraint($contained_tc), + type_parameter => $contained_tc, ); } @@ -81,6 +86,10 @@ Moose::Meta::TypeConstraint::Parameterizable - Higher Order type constraints for =item B +=item B + +Given an array of type constraints, parameterize the current type constraint. + =item B =back diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 582c1c9..ac6802c 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -121,19 +121,35 @@ sub create_type_constraint_union (@) { sub create_parameterized_type_constraint ($) { my $type_constraint_name = shift; - my ($base_type, $type_parameter) = _parse_parameterized_type_constraint($type_constraint_name); + my ($base_type, $type_parameter_str) = _parse_parameterized_type_constraint($type_constraint_name); - (defined $base_type && defined $type_parameter) + (defined $base_type && defined $type_parameter_str) || Moose->throw_error("Could not parse type name ($type_constraint_name) correctly"); - ($REGISTRY->has_type_constraint($base_type)) - || Moose->throw_error("Could not locate the base type ($base_type)"); + if ($REGISTRY->has_type_constraint($base_type)) { + my $base_type_tc = $REGISTRY->get_type_constraint($base_type); + return _create_parameterized_type_constraint( + $type_constraint_name, + $base_type_tc, + $type_parameter_str, + ); + } else { + Moose->throw_error("Could not locate the base type ($base_type)"); + } +} - return Moose::Meta::TypeConstraint::Parameterized->new( - name => $type_constraint_name, - parent => $REGISTRY->get_type_constraint($base_type), - type_parameter => find_or_create_isa_type_constraint($type_parameter), - ); +sub _create_parameterized_type_constraint { + my ($tc_name, $base_type_tc, $type_parameter_str) = @_; + my @type_parameters_tc = map {find_or_create_isa_type_constraint($_)} ($type_parameter_str); + if($base_type_tc->can('parameterize')) { + return $base_type_tc->parameterize($tc_name,@type_parameters_tc); + } else { + return Moose::Meta::TypeConstraint::Parameterized->new( + name => $tc_name, + parent => $base_type_tc, + type_parameter => $type_parameters_tc[0], + ); + } } #should we also support optimized checks? diff --git a/t/040_type_constraints/010_misc_type_tests.t b/t/040_type_constraints/010_misc_type_tests.t index adbd0db..75e2fb8 100644 --- a/t/040_type_constraints/010_misc_type_tests.t +++ b/t/040_type_constraints/010_misc_type_tests.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 8; +use Test::More tests => 19; use Test::Exception; BEGIN { @@ -51,14 +51,75 @@ ok $subtype2 => 'made a subtype of our subtype'; # testing the parameterize method { - package Test::Moose::Meta::TypeConstraint::Parameterizable; - - use Moose; - use Moose::Util::TypeConstraints; - my $parameterizable = subtype 'parameterizable_hashref', as 'HashRef'; my $parameterized = subtype 'parameterized_hashref', as 'HashRef[Int]'; -} \ No newline at end of file + + my $int = Moose::Util::TypeConstraints::find_type_constraint('Int'); + + my $from_parameterizable = $parameterizable->parameterize($int); + + isa_ok $parameterizable, 'Moose::Meta::TypeConstraint::Parameterizable', + => 'Got expected type instance'; + + package Test::Moose::Meta::TypeConstraint::Parameterizable; + use Moose; + + has parameterizable => (is=>'rw', isa=>$parameterizable); + has parameterized => (is=>'rw', isa=>$parameterized); + has from_parameterizable => (is=>'rw', isa=>$from_parameterizable); +} + +# Create and check a dummy object + +ok my $params = Test::Moose::Meta::TypeConstraint::Parameterizable->new() + => 'Create Dummy object for testing'; + +isa_ok $params, 'Test::Moose::Meta::TypeConstraint::Parameterizable' + => 'isa correct type'; + +# test parameterizable + +lives_ok sub { + $params->parameterizable({a=>'Hello', b=>'World'}); +} => 'No problem setting parameterizable'; + +is_deeply $params->parameterizable, {a=>'Hello', b=>'World'} + => 'Got expected values'; + +# test parameterized + +lives_ok sub { + $params->parameterized({a=>1, b=>2}); +} => 'No problem setting parameterized'; + +is_deeply $params->parameterized, {a=>1, b=>2} + => 'Got expected values'; + +throws_ok sub { + $params->parameterized({a=>'Hello', b=>'World'}); +}, qr/Attribute \(parameterized\) does not pass the type constraint/ + => 'parameterized throws expected error'; + +# test from_parameterizable + +lives_ok sub { + $params->from_parameterizable({a=>1, b=>2}); +} => 'No problem setting from_parameterizable'; + +is_deeply $params->from_parameterizable, {a=>1, b=>2} + => 'Got expected values'; + +throws_ok sub { + $params->from_parameterizable({a=>'Hello', b=>'World'}); +}, qr/Attribute \(from_parameterizable\) does not pass the type constraint/ + => 'from_parameterizable throws expected error'; + + + + + + + \ No newline at end of file