From: John Napiorkowski Date: Wed, 22 Oct 2008 19:37:42 +0000 (+0000) Subject: first pass at restoring parametrization changes and tests X-Git-Tag: 0.60~17^2~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=90e788848a55f0aabffc147603164a044b1b57dc;p=gitmo%2FMoose.git first pass at restoring parametrization changes and tests --- diff --git a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm index bc3b9ce..f08f9c8 100644 --- a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm +++ b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm @@ -9,6 +9,8 @@ $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::TypeConstraint'; +use Moose::Meta::TypeConstraint::Parameterized; +use Moose::Util::TypeConstraints (); __PACKAGE__->meta->add_attribute('constraint_generator' => ( accessor => 'constraint_generator', @@ -40,6 +42,29 @@ sub _can_coerce_constraint_from { }; } +sub _parse_type_parameter { + my ($self, $type_parameter) = @_; + return Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($type_parameter); +} + +sub parameterize { + my ($self, $type_parameter) = @_; + + my $contained_tc = $self->_parse_type_parameter($type_parameter); + + if ( $contained_tc->isa('Moose::Meta::TypeConstraint') ) { + my $tc_name = $self->name . '[' . $contained_tc->name . ']'; + return Moose::Meta::TypeConstraint::Parameterized->new( + name => $tc_name, + parent => $self, + type_parameter => $contained_tc, + ); + } + else { + Moose->throw_error("The type parameter must be a Moose meta type"); + } +} + 1; @@ -62,6 +87,11 @@ Moose::Meta::TypeConstraint::Parameterizable - Higher Order type constraints for =item B +=item B + +Given a single type constraint string, this method parses the string +and parameterizes the type based on the parsed string. + =item B =back diff --git a/lib/Moose/Meta/TypeConstraint/Union.pm b/lib/Moose/Meta/TypeConstraint/Union.pm index 9479ccf..77a6917 100644 --- a/lib/Moose/Meta/TypeConstraint/Union.pm +++ b/lib/Moose/Meta/TypeConstraint/Union.pm @@ -21,7 +21,8 @@ __PACKAGE__->meta->add_attribute('type_constraints' => ( sub new { my ($class, %options) = @_; my $self = $class->SUPER::new( - name => (join '|' => sort map { $_->name } @{$options{type_constraints}}), + name => (join '|' => sort {$a cmp $b} + map { $_->name } @{$options{type_constraints}}), parent => undef, message => undef, hand_optimized_type_constraint => undef, diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 0261004..a9c9310 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -103,22 +103,30 @@ sub create_parameterized_type_constraint { (defined $base_type && defined $type_parameter) || Moose->throw_error("Could not parse type name ($type_constraint_name) correctly"); - # We need to get the relevant type constraints and use them to - # create the name to ensure that we end up with the fully - # normalized name, because the user could've passed something like - # HashRef[Str|Int] and we want to make that HashRef[Int|Str]. - my $base_type_tc = $REGISTRY->get_type_constraint($base_type) - || Moose->throw_error("Could not locate the base type ($base_type)"); - my $parameter_tc = find_or_create_isa_type_constraint($type_parameter) - || Moose->throw_error("Could not locate the parameter type ($type_parameter)"); - - return Moose::Meta::TypeConstraint::Parameterized->new( - name => $base_type_tc->name . '[' . $parameter_tc->name . ']', - parent => $base_type_tc, - type_parameter => $parameter_tc, - ); + if ($REGISTRY->has_type_constraint($base_type)) { + my $base_type_tc = $REGISTRY->get_type_constraint($base_type); + return _create_parameterized_type_constraint( + $base_type_tc, + $type_parameter + ); + } else { + Moose->throw_error("Could not locate the base type ($base_type)"); + } } +sub _create_parameterized_type_constraint { + my ( $base_type_tc, $type_parameter ) = @_; + if ( $base_type_tc->can('parameterize') ) { + return $base_type_tc->parameterize($type_parameter); + } else { + return Moose::Meta::TypeConstraint::Parameterized->new( + name => $base_type_tc->name . '[' . $type_parameter . ']', + parent => $base_type_tc, + type_parameter => find_or_create_isa_type_constraint($type_parameter), + ); + } +} + #should we also support optimized checks? sub create_class_type_constraint { my ( $class, $options ) = @_; diff --git a/t/040_type_constraints/027_parameterize_from.t b/t/040_type_constraints/027_parameterize_from.t new file mode 100644 index 0000000..f917e28 --- /dev/null +++ b/t/040_type_constraints/027_parameterize_from.t @@ -0,0 +1,79 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 12; +use Test::Exception; + +BEGIN { + use_ok('Moose::Util::TypeConstraints'); +} + +# testing the parameterize method + +{ + my $parameterizable = subtype 'parameterizable_hashref', as 'HashRef'; + + my $parameterized = subtype 'parameterized_hashref', as 'HashRef[Int]'; + + 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';