Revision history for MooseX-Types-Structured
-0.01 25 September 2008
+0.01 27 October 2008
Completed basic requirements, documentation and tests.
--- /dev/null
+package MooseX::Meta::TypeCoercion::Structured;
+
+use Moose;
+extends 'Moose::Meta::TypeCoercion';
+
+=head1 NAME
+
+MooseX::Meta::TypeCoercion::Structured - Coerce structured type constraints.
+
+=head1 DESCRIPTION
+
+We need to make sure we can properly coerce the structure elements inside a
+structured type constraint.
+
+This class is TDB once we fully understand the requirements for deep coercions.
+
+=head1 METHODS
+
+This class defines the following methods.
+
+=head1 SEE ALSO
+
+The following modules or resources may be of interest.
+
+L<Moose>, L<Moose::Meta::TypeCoercion>
+
+=head1 AUTHOR
+
+John Napiorkowski, C<< <jjnapiork@cpan.org> >>
+
+=head1 COPYRIGHT & LICENSE
+
+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
use Moose;
use Moose::Util::TypeConstraints ();
+use MooseX::Meta::TypeCoercion::Structured;
extends 'Moose::Meta::TypeConstraint';
=head1 NAME
This class defines the following methods.
+=head2 new
+
+Initialization stuff.
+
+=cut
+
+around 'new' => sub {
+ my ($new, $class, @args) = @_;
+ my $self = $class->$new(@args);
+ $self->coercion(MooseX::Meta::TypeCoercion::Structured->new(
+ type_constraint => $self,
+ ));
+ return $self;
+};
+
=head2 generate_constraint_for ($type_constraints)
Given some type constraints, use them to generate validation rules for an ref
=cut
sub parameterize {
- my ($self, @type_constraints) = @_;
+ my ($self, @type_constraints) = @_;
+ my $class = ref $self;
my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']';
- return __PACKAGE__->new(
+ return $class->new(
name => $name,
parent => $self,
type_constraints => \@type_constraints,
=head2 equals
+Override the base class behavior.
+
+=cut
+
+sub equals {
+ my ( $self, $type_or_name ) = @_;
+ my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+
+ return unless $other->isa(__PACKAGE__);
+
+ return (
+ $self->type_constraints_equals($other)
+ and
+ $self->parent->equals( $other->parent )
+ );
+}
+
+=head2 type_constraints_equals
+
+Checks to see if the internal type contraints are equal.
+
+=cut
+
+sub type_constraints_equals {
+ my ($self, $other) = @_;
+ my @self_type_constraints = @{$self->type_constraints||[]};
+ my @other_type_constraints = @{$other->type_constraints||[]};
+
+ ## Incoming ay be either arrayref or hashref, need top compare both
+ while(@self_type_constraints) {
+ my $self_type_constraint = shift @self_type_constraints;
+ my $other_type_constraint = shift @other_type_constraints
+ || return; ## $other needs the same number of children.
+
+ if( ref $self_type_constraint) {
+ $self_type_constraint->equals($other_type_constraint)
+ || return; ## type constraints obviously need top be equal
+ } else {
+ $self_type_constraint eq $other_type_constraint
+ || return; ## strings should be equal
+ }
+
+ }
+
+ return 1; ##If we get this far, everything is good.
+}
+
=head2 get_message
-Want to override this to set a more useful error message
+May want to override this to set a more useful error message
=head1 SEE ALSO
age=>$age->years );
};
-You also need to exercise some care when you try to subtype a structured type
+=head2 Subtyping a structured subtype
+
+You need to exercise some care when you try to subtype a structured type
as in this example:
subtype Person,
subtype FriendlyPerson,
as Person[name=>Str, age=>Int, totalFriends=>Int];
-This will actually work BUT you have to take care the the subtype has a
+This will actually work BUT you have to take care that the subtype has a
structure that does not contradict the structure of it's parent. For now the
above works, but I will probably clarify how this works at a future point, so
it's recommended to avoid (should not realy be needed so much anyway). For
-now this is supported in an EXPERIMENTAL way.
+now this is supported in an EXPERIMENTAL way. In the future we will probably
+clarify how to augment existing structured types.
+
+=head2 Coercions
+
+Coercions currently work for 'one level' deep. That is you can do:
+
+ subtype Person,
+ as Dict[name=>Str, age=>Int];
+
+ subtype Fullname,
+ as Dict[first=>Str, last=>Str];
+
+ coerce Person,
+ from BlessedPersonObject,
+ via { +{name=>$_->name, age=>$_->age} },
+ from ArrayRef,
+ via { +{name=>$_->[0], age=>$_->[1] },
+ from Dict[fullname=>Fullname, dob=>DateTime],
+ via {
+ my $age = $_->dob - DateTime->now;
+ +{
+ name=> $_->{fullname}->{first} .' '. $_->{fullname}->{last},
+ age=>$age->years
+ }
+ };
+
+And that should just work as expected. However, if there are any 'inner'
+coercions, such as a coercion on 'Fullname' or on 'DateTime', that coercion
+won't currently get activated.
+
+Please see the test '07-coerce.t' for a more detailed example.
+
+=head1 TYPE CONSTRAINTS
+
+This type library defines the following constraints.
+
+=head2 Tuple[@constraints]
+
+This defines an arrayref based constraint which allows you to validate a specific
+list of constraints. For example:
+
+ Tuple[Int,Str]; ## Validates [1,'hello']
+ Tuple[Str|Object, Int]; ##Validates ['hello', 1] or [$object, 2]
+
+=head2 Dict [%constraints]
+
+This defines a hashref based constraint which allowed you to validate a specific
+hashref. For example:
+
+ Dict[name=>Str, age=>Int]; ## Validates {name=>'John', age=>39}
=cut
delete $values{$key};
unless($type_constraint->check($value)) {
return;
+ #if ($type_constraint->has_coercion) {
+ # my $temp = $type_constraint->coerce($value);
+ # use Data::Dump qw/dump/; warn dump $value, $temp;
+ # unless($type_constraint->check($temp)) {
+ # return;
+ # }
+ #} else {
+ # return;
+ #}
}
} else {
return;
L<Moose>, L<MooseX::TypeLibrary>, L<Moose::Meta::TypeConstraint>,
L<MooseX::Meta::TypeConstraint::Structured>
+=head1 TODO
+
+Need to clarify deep coercions, need to clarify subtypes of subtypes.
+
=head1 AUTHOR
John Napiorkowski, C<< <jjnapiork@cpan.org> >>
BEGIN {
use strict;
use warnings;
- use Test::More tests=>12;
+ use Test::More tests=>44;
use Test::Exception;
}
-{
- ## Tests for the Moose::Meta::TypeConstraints API stuff (equals, etc)
- package Test::MooseX::Meta::TypeConstraint::Structured::API;
-
- use Moose;
- use MooseX::Types::Structured qw(Dict Tuple);
- use MooseX::Types::Moose qw(Int Str Object ArrayRef HashRef);
- use MooseX::Types -declare => [qw(
- MyDict1 MyDict2 MyDict3 subMyDict3
- MyTuple1 MyTuple2 MyTuple3 subMyTuple3
- )];
-
- ## Create some sample Dicts
-
- my $MyDict1 = subtype MyDict1,
- as Dict[name=>Str, age=>Int];
-
- my $MyDict2 = subtype MyDict2,
- as Dict[name=>Str, age=>Int];
-
- my $MyDict3 = subtype MyDict3,
- as Dict[key=>Int, anotherkey=>Str];
-
- my $subMyDict3 = subtype subMyDict3,
- as MyDict3;
-
- ## Create some sample Tuples
-
- my $MyTuple1 = subtype MyTuple1,
- as Tuple[Int,Int,Str];
-
- my $MyTuple2 = subtype MyTuple2,
- as Tuple[Int,Int,Str];
-
- my $MyTuple3 = subtype MyTuple3,
- as Tuple[Object, HashRef];
-
- my $subMyTuple3 = subtype subMyTuple3,
- as MyTuple3;
-}
+use MooseX::Types::Structured qw(Dict Tuple);
+use MooseX::Types::Moose qw(Int Str Object ArrayRef HashRef);
+use MooseX::Types -declare => [qw(
+ MyDict1 MyDict2 MyDict3 subMyDict3 subMyDict1
+ MyTuple1 MyTuple2 MyTuple3 subMyTuple3
+)];
+
+## Create some sample Dicts
+
+subtype MyDict1,
+ as Dict[name=>Str, age=>Int];
+
+subtype subMyDict1,
+ as MyDict1;
+
+subtype MyDict2,
+ as Dict[name=>Str, age=>Int];
+
+subtype MyDict3,
+ as Dict[key=>Int, anotherkey=>Str];
+
+subtype subMyDict3,
+ as MyDict3;
+
+## Create some sample Tuples
+
+subtype MyTuple1,
+ as Tuple[Int,Int,Str];
+
+subtype MyTuple2,
+ as Tuple[Int,Int,Str];
+
+subtype MyTuple3,
+ as Tuple[Object, HashRef];
+
+subtype subMyTuple3,
+ as MyTuple3;
## Test equals
-ok $MyDict1->equals($MyDict2), '$MyDict1 == $MyDict2';
-ok $MyDict2->equals($MyDict1), '$MyDict2 == $MyDict1';
-ok ! $MyDict1->equals($MyDict3), '$MyDict1 == $MyDict3';
-ok ! $MyDict2->equals($MyDict3), '$MyDict2 == $MyDict3';
-ok ! $MyDict3->equals($MyDict2), '$MyDict3 == $MyDict2';
-ok ! $MyDict3->equals($MyDict1), '$MyDict3 == $MyDict1';
+ok ( MyDict1->equals(MyDict2), 'MyDict1 == MyDict2');
+ok ( MyDict2->equals(MyDict1), 'MyDict2 == MyDict1');
+ok (!MyDict1->equals(MyDict3), 'MyDict1 == MyDict3');
+ok (!MyDict2->equals(MyDict3), 'MyDict2 == MyDict3');
+ok (!MyDict3->equals(MyDict2), 'MyDict3 == MyDict2');
+ok (!MyDict3->equals(MyDict1), 'MyDict3 == MyDict1');
-ok $MyTuple1->equals($MyTuple2), '$MyTuple1 == $MyTuple2';
-ok $MyTuple2->equals($MyTuple1), '$MyTuple2 == $MyTuple1';
-ok ! $MyTuple1->equals($MyTuple3), '$MyTuple1 == $MyTuple3';
-ok ! $MyTuple2->equals($MyTuple3), '$MyTuple2 == $MyTuple3';
-ok ! $MyTuple3->equals($MyTuple2), '$MyTuple3 == $MyTuple2';
-ok ! $MyTuple3->equals($MyTuple1), '$MyTuple3 == $MyTuple1';
+ok ( MyTuple1->equals(MyTuple2), 'MyTuple1 == MyTuple2');
+ok ( MyTuple2->equals(MyTuple1), 'MyTuple2 == MyTuple1');
+ok (!MyTuple1->equals(MyTuple3), 'MyTuple1 == MyTuple3');
+ok (!MyTuple2->equals(MyTuple3), 'MyTuple2 == MyTuple3');
+ok (!MyTuple3->equals(MyTuple2), 'MyTuple3 == MyTuple2');
+ok (!MyTuple3->equals(MyTuple1), 'MyTuple3 == MyTuple1');
## Test is_a_type_of
+ok ( MyDict1->is_a_type_of(Dict), 'MyDict1 is_a_type_of Dict');
+ok (!MyDict1->is_a_type_of(Tuple), 'MyDict1 NOT is_a_type_of Tuple');
+ok ( MyDict1->is_a_type_of(MyDict2), 'MyDict1 is_a_type_of MyDict2');
+ok ( MyDict2->is_a_type_of(MyDict1), 'MyDict2 is_a_type_of MyDict1');
+ok (!MyDict1->is_a_type_of(MyDict3), 'MyDict1 NOT is_a_type_of MyDict3');
+ok (!MyDict2->is_a_type_of(MyDict3), 'MyDict2 NOT is_a_type_of MyDict3');
+ok ( subMyDict1->is_a_type_of(Dict), 'subMyDict1 type of Dict');
+ok ( subMyDict1->is_a_type_of(MyDict1), 'subMyDict1 type of MyDict1');
+ok ( subMyDict1->is_a_type_of(subMyDict1), 'subMyDict1 type of subMyDict1');
+ok ( subMyDict1->is_a_type_of(MyDict2), 'subMyDict1 type of MyDict2');
+
+ok ( MyTuple1->is_a_type_of(Tuple), 'MyTuple1 is_a_type_of Tuple');
+ok (!MyTuple1->is_a_type_of(Dict), 'MyTuple1 NOT is_a_type_of Dict');
+ok ( MyTuple1->is_a_type_of(MyTuple2), 'MyTuple1 is_a_type_of MyTuple2');
+ok ( MyTuple2->is_a_type_of(MyTuple1), 'MyTuple2 is_a_type_of MyTuple1');
+ok (!MyTuple1->is_a_type_of(MyTuple3), 'MyTuple1 NOT is_a_type_of MyTuple3');
+ok (!MyTuple2->is_a_type_of(MyTuple3), 'MyTuple2 NOT is_a_type_of MyTuple3');
+
## is_subtype_of
+ok ( MyDict1->is_subtype_of(Dict), 'MyDict1 is_subtype_of Dict');
+ok (!MyDict1->is_subtype_of(Tuple), 'MyDict1 NOT is_subtype_of Tuple');
+ok (!MyDict1->is_subtype_of(MyDict2), 'MyDict1 is_subtype_of MyDict2');
+ok (!MyDict2->is_subtype_of(MyDict1), 'MyDict2 is_subtype_of MyDict1');
+ok (!MyDict1->is_subtype_of(MyDict3), 'MyDict1 NOT is_subtype_of MyDict3');
+ok (!MyDict2->is_subtype_of(MyDict3), 'MyDict2 NOT is_subtype_of MyDict3');
+ok ( subMyDict1->is_subtype_of(Dict), 'subMyDict1 is_subtype_of Dict');
+ok ( subMyDict1->is_subtype_of(MyDict1), 'subMyDict1 is_subtype_of MyDict1');
+ok (!subMyDict1->is_subtype_of(subMyDict1), 'subMyDict1 is_subtype_of subMyDict1');
+ok ( subMyDict1->is_subtype_of(MyDict2), 'subMyDict1 is_subtype_of MyDict2');
+
+ok ( MyTuple1->is_subtype_of(Tuple), 'MyTuple1 is_subtype_of Tuple');
+ok (!MyTuple1->is_subtype_of(Dict), 'MyTuple1 NOT is_subtype_of Dict');
+ok (!MyTuple1->is_subtype_of(MyTuple2), 'MyTuple1 is_subtype_of MyTuple2');
+ok (!MyTuple2->is_subtype_of(MyTuple1), 'MyTuple2 is_subtype_of MyTuple1');
+ok (!MyTuple1->is_subtype_of(MyTuple3), 'MyTuple1 NOT is_subtype_of MyTuple3');
+ok (!MyTuple2->is_subtype_of(MyTuple3), 'MyTuple2 NOT is_subtype_of MyTuple3');
BEGIN {
use strict;
use warnings;
- use Test::More tests=>1;
+ use Test::More tests=>16;
use Test::Exception;
}
use MooseX::Types::Structured qw(Dict Tuple);
use MooseX::Types::Moose qw(Int Str Object ArrayRef HashRef);
use MooseX::Types -declare => [qw(
+ myDict myTuple Fullname
)];
+ subtype myDict,
+ as Dict[name=>Str, age=>Int];
+
+ subtype Fullname,
+ as Dict[first=>Str, last=>Str];
+
+ coerce Fullname,
+ from ArrayRef,
+ via { +{first=>$_->[0], last=>$_->[1]} };
+
+ subtype myTuple,
+ as Tuple[Str, Int];
+ ## Create some coercions. Note the dob_epoch could be a more useful convert
+ ## from a dob datetime object, I'm just lazy.
+
+ coerce myDict,
+ from Int,
+ via { +{name=>'JohnDoe', age=>$_} },
+ from Dict[aname=>HashRef, dob_in_years=>Int],
+ via { +{
+ name=> $_->{aname}->{first} .' '. $_->{aname}->{last},
+ age=>$_->{dob_in_years},
+ }
+ },
+ from Dict[bname=>HashRef, dob_in_years=>Int],
+ via { +{
+ name=> $_->{bname}->{first} .' '. $_->{bname}->{last},
+ age=>$_->{dob_in_years},
+ }
+ },
+ from Dict[fullname=>Fullname, dob_epoch=>Int],
+ via { +{
+ name=> $_->{fullname}->{first} .' '. $_->{fullname}->{last},
+ age=>$_->{dob_epoch}}
+ },
+ from myTuple,
+ via { +{name=>$_->[0], age=>$_->[1]} };
+
+ has 'stuff' => (is=>'rw', isa=>myDict, coerce=>1);
}
+## Create an object to test
+
+ok my $person = Test::MooseX::Meta::TypeConstraint::Structured::Coerce->new();
+isa_ok $person, 'Test::MooseX::Meta::TypeConstraint::Structured::Coerce';## Try out the coercions
+
+ok $person->stuff({name=>"John",age=>25}), 'Set Stuff {name=>"John",age=>25}';
+is_deeply $person->stuff, {name=>"John",age=>25}, 'Correct set';
+
+ok $person->stuff(30), 'Set Stuff 30';
+is_deeply $person->stuff, {name=>"JohnDoe",age=>30}, 'Correct set';
+
+ok $person->stuff({aname=>{first=>"frank", last=>"herbert"},dob_in_years=>80}),
+ '{{first=>"frank", last=>"herbert"},80}';
+
+is_deeply $person->stuff, {name=>"frank herbert",age=>80}, 'Correct set';
+ok $person->stuff({bname=>{first=>"frankbbb", last=>"herbert"},dob_in_years=>84}),
+ '{{first=>"frankbbb", last=>"herbert"},84}';
+
+is_deeply $person->stuff, {name=>"frankbbb herbert",age=>84}, 'Correct set';
+
+ok $person->stuff(["mary",40]), 'Set Stuff ["mary",40]';
+is_deeply $person->stuff, {name=>"mary",age=>40}, 'Correct set';
+
+ok $person->stuff({fullname=>{first=>"frank", last=>"herbert1"},dob_epoch=>85}),
+ '{{first=>"frank", last=>"herbert1"},85}';
+
+is_deeply $person->stuff, {name=>"frank herbert1",age=>85}, 'Correct set';
+
+SKIP: {
+ skip 'deep coercions not yet supported', 2, 1;
+
+ ok $person->stuff({fullname=>["frank", "herbert2"],dob_epoch=>86}),
+ '{fullname=>["frank", "herbert2"],dob_epoch=>86}';
+
+ is_deeply $person->stuff, {name=>"frank herbert2",age=>86}, 'Correct set';
+}
projects / gitmo/MooseX-Types-Structured.git / commitdiff