From: John Napiorkowski Date: Tue, 7 Oct 2008 22:17:05 +0000 (+0000) Subject: really register the types, more advanced tests, including an outline for structured... X-Git-Tag: 0.01~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Types-Structured.git;a=commitdiff_plain;h=67a8bc0491edda720c7450433ccdf3cb07edb6ff really register the types, more advanced tests, including an outline for structured inheritance --- diff --git a/lib/MooseX/Meta/TypeConstraint/Structured.pm b/lib/MooseX/Meta/TypeConstraint/Structured.pm index eea8d51..10bb30a 100644 --- a/lib/MooseX/Meta/TypeConstraint/Structured.pm +++ b/lib/MooseX/Meta/TypeConstraint/Structured.pm @@ -71,13 +71,18 @@ Given a ref of type constraints, create a structured type. =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, @_); + }, ); } diff --git a/lib/MooseX/Types/Structured.pm b/lib/MooseX/Types/Structured.pm index 9a66f19..a4c6be6 100644 --- a/lib/MooseX/Types/Structured.pm +++ b/lib/MooseX/Types/Structured.pm @@ -108,83 +108,73 @@ method, granting some interesting possibilities for coercion. Try: 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 automatically wraps a L -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 @@ -203,5 +193,5 @@ This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut - -1; \ No newline at end of file + +1; diff --git a/t/05-advanced.t b/t/05-advanced.t index ea1e302..b05fb82 100644 --- a/t/05-advanced.t +++ b/t/05-advanced.t @@ -1,7 +1,7 @@ BEGIN { use strict; use warnings; - use Test::More tests=>12; + use Test::More tests=>16; use Test::Exception; } @@ -38,7 +38,7 @@ BEGIN { subtype MinFiveChars, as Str, where { length($_) > 5}; - + ## Dict key overloading subtype MorePersonalInfo, as PersonalInfo[name=>MinFiveChars]; @@ -56,7 +56,7 @@ ok my $obj = Test::MooseX::Meta::TypeConstraint::Structured::Advanced->new isa_ok $obj => 'Test::MooseX::Meta::TypeConstraint::Structured::Advanced' => 'Created correct object type.'; - + ## Test EqualLengthAttr lives_ok sub { @@ -93,11 +93,11 @@ throws_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]]}); @@ -109,4 +109,28 @@ throws_ok sub { }, 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]]}; +}