From: John Napiorkowski Date: Fri, 12 Sep 2008 18:25:32 +0000 (+0000) Subject: - moved the ->parameterize tests to own test suite X-Git-Tag: 0.58~37^2~14 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=08380fdb9f79107ab7aaf353edd03757ad3e8400;p=gitmo%2FMoose.git - moved the ->parameterize tests to own test suite - changed t/030_roles/017_extending_role_attrs.t to deal with the fact we sort union type constraints - removed ugly hack from ->parameterize to force a tc name - union types now sort @TC and properly canonicalize their names - changed the regex parsing for stringed type constraints so that we ignore pointless whitespace and have support for upcoming structured types --- diff --git a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm index 0dd7766..4fdfbe6 100644 --- a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm +++ b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm @@ -48,26 +48,18 @@ sub parse_parameter_str { } sub parameterize { - 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; + my ($self, $contained_tc) = @_; + + 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"); } - - unless($contained_tc->isa('Moose::Meta::TypeConstraint')) { - Moose->throw_error("The type parameter must be a Moose meta type"); - } - - return Moose::Meta::TypeConstraint::Parameterized->new( - name => $tc_name, - parent => $self, - type_parameter => $contained_tc, - ); } diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index c4cd826..8658c82 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -105,22 +105,18 @@ sub create_type_constraint_union (@) { (scalar @type_constraint_names >= 2) || Moose->throw_error("You must pass in at least 2 type names to make a union"); - ($REGISTRY->has_type_constraint($_)) - || Moose->throw_error("Could not locate type constraint ($_) for the union") - foreach @type_constraint_names; - + my @type_constraints = sort { $a->name cmp $b->name} map { + find_or_parse_type_constraint($_) || + Moose->throw_error("Could not locate type constraint ($_) for the union") + } @type_constraint_names; + return Moose::Meta::TypeConstraint::Union->new( - type_constraints => [ - map { - $REGISTRY->get_type_constraint($_) - } @type_constraint_names - ], + type_constraints => [@type_constraints] ); } sub create_parameterized_type_constraint ($) { my $type_constraint_name = shift; - my ($base_type, $type_parameter_str) = _parse_parameterized_type_constraint($type_constraint_name); (defined $base_type && defined $type_parameter_str) @@ -129,7 +125,6 @@ sub create_parameterized_type_constraint ($) { 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, ); @@ -139,13 +134,13 @@ sub create_parameterized_type_constraint ($) { } sub _create_parameterized_type_constraint { - my ($tc_name, $base_type_tc, $type_parameter_str) = @_; + my ($base_type_tc, $type_parameter_str) = @_; if($base_type_tc->can('parameterize')) { my @type_parameters_tc = $base_type_tc->parse_parameter_str($type_parameter_str); - return $base_type_tc->parameterize($tc_name, @type_parameters_tc); + return $base_type_tc->parameterize( @type_parameters_tc); } else { return Moose::Meta::TypeConstraint::Parameterized->new( - name => $tc_name, + name => $base_type_tc->name .'['. $type_parameter_str .']', parent => $base_type_tc, type_parameter => find_or_create_isa_type_constraint($type_parameter_str), ); @@ -235,7 +230,7 @@ sub find_or_parse_type_constraint ($) { return $constraint; } elsif (_detect_type_constraint_union($type_constraint_name)) { $constraint = create_type_constraint_union($type_constraint_name); - } elsif (_detect_parameterized_type_constraint($type_constraint_name)) { + } elsif (_detect_parameterized_type_constraint($type_constraint_name)) { $constraint = create_parameterized_type_constraint($type_constraint_name); } else { return; @@ -452,19 +447,26 @@ sub _install_type_coercions ($$) { my $any; - my $type = qr{ $valid_chars+ (?: \[ (??{$any}) \] )? }x; - my $type_capture_parts = qr{ ($valid_chars+) (?: \[ ((??{$any})) \] )? }x; - my $type_with_parameter = qr{ $valid_chars+ \[ (??{$any}) \] }x; + my $type = qr{ $valid_chars+ (?: \[ \s* (??{$any}) \s* \] )? }x; + my $type_capture_parts = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x; + my $type_with_parameter = qr{ $valid_chars+ \[ \s* (??{$any}) \s* \] }x; my $op_union = qr{ \s* \| \s* }x; my $union = qr{ $type (?: $op_union $type )+ }x; - $any = qr{ $type | $union }x; + ## New Stuff for structured types. + my $comma = qr{,}; + my $indirection = qr{=>}; + my $divider_ops = qr{ $comma | $indirection }x; + my $structure_divider = qr{\s* $divider_ops \s*}x; + my $structure_elements = qr{ ($type $structure_divider*)+ }x; + + $any = qr{ $type | $union | $structure_elements }x; sub _parse_parameterized_type_constraint { { no warnings 'void'; $any; } # force capture of interpolated lexical - $_[0] =~ m{ $type_capture_parts }x; - return ($1, $2); + my($base, $elements) = ($_[0] =~ m{ $type_capture_parts }x); + return ($base, split($structure_divider, $elements)); } sub _detect_parameterized_type_constraint { diff --git a/t/030_roles/017_extending_role_attrs.t b/t/030_roles/017_extending_role_attrs.t index 95572a5..9b46f59 100644 --- a/t/030_roles/017_extending_role_attrs.t +++ b/t/030_roles/017_extending_role_attrs.t @@ -99,7 +99,7 @@ is($baz->baz, 99, '... got the extended attribute'); $baz->baz('Foo'); is($baz->baz, 'Foo', "... can change the attribute's value to a ClassName"); -throws_ok { $baz->baz("zonk") } qr/^Attribute \(baz\) does not pass the type constraint because: Validation failed for 'Int \| ClassName' failed with value zonk at /; +throws_ok { $baz->baz("zonk") } qr/^Attribute \(baz\) does not pass the type constraint because: Validation failed for 'ClassName \| Int' failed with value zonk at /; is_deeply($baz->baz, 'Foo', "... still has the old ClassName value"); @@ -137,10 +137,10 @@ is($quux->quux, 100, "... can change the attribute's value to an Int"); $quux->quux(["hi"]); is_deeply($quux->quux, ["hi"], "... can change the attribute's value to an ArrayRef"); -throws_ok { $quux->quux("quux") } qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'Positive \| ArrayRef' failed with value quux at /; +throws_ok { $quux->quux("quux") } qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef \| Positive' failed with value quux at /; is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value"); -throws_ok { $quux->quux({a => 1}) } qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'Positive \| ArrayRef' failed with value HASH\(\w+\) at /; +throws_ok { $quux->quux({a => 1}) } qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef \| Positive' failed with value HASH\(\w+\) at /; is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value"); diff --git a/t/040_type_constraints/010_misc_type_tests.t b/t/040_type_constraints/010_misc_type_tests.t index 75e2fb8..779bcf3 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 => 19; +use Test::More tests => 8; use Test::Exception; BEGIN { @@ -47,79 +47,3 @@ ok $subtype1 => 'made a subtype from our type object'; my $subtype2 = subtype 'New2' => as $subtype1; ok $subtype2 => 'made a subtype of our subtype'; - -# 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'; - - - - - - - \ No newline at end of file