=cut
sub parameterize {
- my ($self, @type_constraints) = @_;
+ my ($self, @type_constraints) = @_;
my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']';
+
return __PACKAGE__->new(
name => $name,
parent => $self,
type_constraints => \@type_constraints,
- constraint_generator => $self->constraint_generator,
+ constraint_generator => $self->constraint_generator || sub {
+ my $tc = shift @_;
+ my $merged_tc = [@$tc, @{$self->parent->type_constraints}];
+ $self->constraint->($merged_tc, @_);
+ },
);
}
This class defines the following methods
-=head2 type_storage
-
-Override the type_storage method so that we can inline the types. We do this
-because if we try to say "type Dict, $dict" or similar, I found that
-L<Moose::Util::TypeConstraints> automatically wraps a L<Moose::Meta::TypeConstraint>
-object around my Structured type, which then throws an error since the base
-Type Constraint object doesn't have a parameterize method.
-
-In the future, might make all these play more nicely with Parameterized types,
-and then this nasty override can go away.
-
=cut
-sub type_storage {
- return {
- Tuple => MooseX::Meta::TypeConstraint::Structured->new(
- name => 'Tuple',
- parent => find_type_constraint('ArrayRef'),
- constraint_generator=> sub {
- ## Get the constraints and values to check
- my @type_constraints = @{shift @_};
- my @values = @{shift @_};
- ## Perform the checking
- while(@type_constraints) {
- my $type_constraint = shift @type_constraints;
- if(@values) {
- my $value = shift @values;
- unless($type_constraint->check($value)) {
- return;
- }
- } else {
- return;
- }
- }
- ## Make sure there are no leftovers.
+Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
+ MooseX::Meta::TypeConstraint::Structured->new(
+ name => "MooseX::Types::Structured::Tuple" ,
+ parent => find_type_constraint('ArrayRef'),
+ constraint_generator=> sub {
+ ## Get the constraints and values to check
+ my @type_constraints = @{shift @_};
+ my @values = @{shift @_};
+ ## Perform the checking
+ while(@type_constraints) {
+ my $type_constraint = shift @type_constraints;
if(@values) {
+ my $value = shift @values;
+ unless($type_constraint->check($value)) {
+ return;
+ }
+ } else {
return;
- } elsif(@type_constraints) {
- return;
- }else {
- return 1;
}
}
- ),
- Dict => MooseX::Meta::TypeConstraint::Structured->new(
- name => 'Dict',
- parent => find_type_constraint('HashRef'),
- constraint_generator=> sub {
- ## Get the constraints and values to check
- my %type_constraints = @{shift @_};
- my %values = %{shift @_};
- ## Perform the checking
- while(%type_constraints) {
- my($key, $type_constraint) = each %type_constraints;
- delete $type_constraints{$key};
- if(exists $values{$key}) {
- my $value = $values{$key};
- delete $values{$key};
- unless($type_constraint->check($value)) {
- return;
- }
- } else {
+ ## Make sure there are no leftovers.
+ if(@values) {
+ return;
+ } elsif(@type_constraints) {
+ return;
+ }else {
+ return 1;
+ }
+ }
+ )
+);
+
+Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
+ MooseX::Meta::TypeConstraint::Structured->new(
+ name => "MooseX::Types::Structured::Dict",
+ parent => find_type_constraint('HashRef'),
+ constraint_generator=> sub {
+ ## Get the constraints and values to check
+ my %type_constraints = @{shift @_};
+ my %values = %{shift @_};
+ ## Perform the checking
+ while(%type_constraints) {
+ my($key, $type_constraint) = each %type_constraints;
+ delete $type_constraints{$key};
+ if(exists $values{$key}) {
+ my $value = $values{$key};
+ delete $values{$key};
+ unless($type_constraint->check($value)) {
return;
}
- }
- ## Make sure there are no leftovers.
- if(%values) {
- return;
- } elsif(%type_constraints) {
+ } else {
return;
- }else {
- return 1;
}
- },
- ),
- };
-}
+ }
+ ## Make sure there are no leftovers.
+ if(%values) {
+ return;
+ } elsif(%type_constraints) {
+ return;
+ }else {
+ return 1;
+ }
+ },
+ )
+);
=head1 SEE ALSO
it under the same terms as Perl itself.
=cut
-
-1;
\ No newline at end of file
+
+1;
BEGIN {
use strict;
use warnings;
- use Test::More tests=>12;
+ use Test::More tests=>16;
use Test::Exception;
}
subtype MinFiveChars,
as Str,
where { length($_) > 5};
-
+
## Dict key overloading
subtype MorePersonalInfo,
as PersonalInfo[name=>MinFiveChars];
isa_ok $obj => 'Test::MooseX::Meta::TypeConstraint::Structured::Advanced'
=> 'Created correct object type.';
-
+
## Test EqualLengthAttr
lives_ok sub {
lives_ok sub {
$obj->PersonalInfoAttr({name=>'John', stats=>[[6,7,8,9,10],[11,12,13,14,15]]});
-} => 'Set MoreLengthPleaseAttr attribute without error 1';
+} => 'Set PersonalInfoAttr attribute without error 1';
lives_ok sub {
$obj->PersonalInfoAttr({name=>'John', stats=>$obj});
-} => 'Set MoreLengthPleaseAttr attribute without error 2';
+} => 'Set PersonalInfoAttr attribute without error 2';
throws_ok sub {
$obj->PersonalInfoAttr({name=>'John', stats=>[[6,7,8,9],[11,12,13,14]]});
}, qr/Attribute \(PersonalInfoAttr\) does not pass the type constraint/
=> q{PersonalInfoAttr correctly fails name=>'John', extra=>1, stats=>[[6,7,8,9,10],[11,12,13,14,15]]};
+## Test MorePersonalInfo
+
+lives_ok sub {
+ $obj->MorePersonalInfo({name=>'Johnnap', stats=>[[6,7,8,9,10],[11,12,13,14,15]]});
+} => 'Set MorePersonalInfo attribute without error 1';
+
+throws_ok sub {
+ $obj->MorePersonalInfo({name=>'Johnnap', stats=>[[6,7,8,9],[11,12,13,14]]});
+}, qr/Attribute \(MorePersonalInfo\) does not pass the type constraint/
+ => q{MorePersonalInfo correctly fails name=>'Johnnap', stats=>[[6,7,8,9],[11,12,13,14]]};
+
+throws_ok sub {
+ $obj->MorePersonalInfo({name=>'Johnnap', extra=>1, stats=>[[6,7,8,9,10],[11,12,13,14,15]]});
+}, qr/Attribute \(MorePersonalInfo\) does not pass the type constraint/
+ => q{MorePersonalInfo correctly fails name=>'Johnnap', extra=>1, stats=>[[6,7,8,9,10],[11,12,13,14,15]]};
+
+SKIP: {
+ skip 'not yet working', 1;
+
+ throws_ok sub {
+ $obj->MorePersonalInfo({name=>'abc', stats=>[[6,7,8,9,10],[11,12,13,14,15]]});
+ }, qr/Attribute \(MorePersonalInfo\) does not pass the type constraint/
+ => q{MorePersonalInfo correctly fails name=>'aaa', extra=>1, stats=>[[6,7,8,9,10],[11,12,13,14,15]]};
+}
projects / gitmo/MooseX-Types-Structured.git / commitdiff