}
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,
- );
}
(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)
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,
);
}
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),
);
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;
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 {
$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");
$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");
use strict;
use warnings;
-use Test::More tests => 19;
+use Test::More tests => 8;
use Test::Exception;
BEGIN {
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
projects / gitmo/Moose.git / commitdiff