Revision history for MooseX-Types-Structured
-0.01 05 September 2008
+0.01 25 September 2008
Completed basic requirements, documentation and tests.
perl_version '5.8.8';
## Module dependencies
-requires 'Moose' => '0.57';
+requires 'Moose' => '0.58';
+requires 'MooseX::TypeLibrary' => '';
## Testing dependencies
build_requires 'Test::More' => '0.70';
+++ /dev/null
-MooseX-Type-Structured
-
-Structured Type Constraints for Moose. This is an extension which provides
-additional type contraint abilities for L<Moose>.
-
-INSTALLATION
-
-To install this module, run the following commands:
-
- perl Makefile.PL
- make
- make test
- make install
-
-SUPPORT AND DOCUMENTATION
-
-After installing, you can find documentation for this module with the
-perldoc command.
-
- perldoc MooseX::Type::Structured
-
-AUTHOR
-
-See L<MooseX::Type::Structured> for more information regarding authors.
-
-LICENSE
-
-See L<MooseX::Type::Structured> for the license.
-
-=cut
-
+++ /dev/null
-package MooseX::Meta::TypeConstraint::Role::Structured;
-
-use Moose::Role;
-use Moose::Util::TypeConstraints;
-requires qw(_normalize_args signature_equals);
-
-=head1 NAME
-
-MooseX::Meta::TypeConstraint::Role::Structured - Structured Type Constraints
-
-=head1 DESCRIPTION
-
-This Role defines the interface and basic behavior of Structured Type Constraints.
-
-Structured type constraints let you assign an internal pattern of type
-constraints to a 'container' constraint. The goal is to make it easier to
-declare constraints like "ArrayRef[Int, Int, Str]" where the constraint is an
-ArrayRef of three elements and the internal constraint on the three is Int, Int
-and Str.
-
-To accomplish this, we add an attribute to the base L<Moose::Meta::TypeConstraint>
-to hold a L</signature>, which is a reference to a pattern of type constraints.
-We then override L</constraint> to check our incoming value to the attribute
-against this signature pattern. Additionally we allow L</optional_signature> to
-hold any optional type constraints. The overall goal is to support something
-like:
-
- has 'attr' => (isa=>'Tuple[Int, Str, Optional[Int, Int]]');
-
-These classes define how the underlying support for this works.
-
-=head1 TYPES
-
-The following types are defined in this class.
-
-=head2 Moose::Meta::TypeConstraint
-
-Used to make sure we can properly validate incoming signatures.
-
-=cut
-
-class_type 'Moose::Meta::TypeConstraint';
-
-=head1 ATTRIBUTES
-
-This class defines the following attributes.
-
-=head2 signature
-
-This is a signature of internal contraints for the contents of the outer
-contraint container.
-
-=cut
-
-has 'signature' => (
- is=>'ro',
- isa=>'Ref',
- required=>1,
-);
-
-=head2 optional_signature
-
-This is a signature of internal contraints for the contents of the outer
-contraint container. These are optional constraints.
-
-=cut
-
-has 'optional_signature' => (
- is=>'ro',
- isa=>'Ref',
- predicate=>'has_optional_signature',
-);
-
-=head1 METHODS
-
-This class defines the following methods.
-
-=head2 equals
-
-modifier to make sure equals descends into the L</signature>
-
-=cut
-
-around 'equals' => sub {
- my ($equals, $self, $compared_type_constraint) = @_;
-
- ## Make sure we are comparing typeconstraints of the same base class
- return unless $compared_type_constraint->isa(__PACKAGE__);
-
- ## Make sure the base equals is also good
- return unless $self->$equals($compared_type_constraint);
-
- ## Make sure the signatures match
- return unless $self->signature_equals($compared_type_constraint);
-
- ## If we get this far, the two are equal
- return 1;
-};
-
-=head1 AUTHOR
-
-John James Napiorkowski <jjnapiork@cpan.org>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-1;
--- /dev/null
+package MooseX::Meta::TypeConstraint::Structured;
+
+use Moose;
+use Moose::Util::TypeConstraints ();
+extends 'Moose::Meta::TypeConstraint';
+
+=head1 NAME
+
+MooseX::Meta::TypeConstraint::Structured - Structured type constraints.
+
+=head1 DESCRIPTION
+
+A structure is a set of L<Moose::Meta::TypeConstraint> that are 'aggregated' in
+such a way as that they are all applied to an incoming list of arguments. The
+idea here is that a Type Constraint could be something like, "An Int followed by
+an Int and then a Str" and that this could be done so with a declaration like:
+
+ Tuple[Int,Int,Str]; ## Example syntax
+
+So a structure is a list of Type constraints (the "Int,Int,Str" in the above
+example) which are intended to function together.
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head2 type_constraints
+
+A list of L<Moose::Meta::TypeConstraint> objects.
+
+=cut
+
+has 'type_constraints' => (
+ is=>'ro',
+ isa=>'Ref',
+ predicate=>'has_type_constraints',
+);
+
+=head2 constraint_generator
+
+A subref or closure that contains the way we validate incoming values against
+a set of type constraints.
+
+=cut
+
+has 'constraint_generator' => (is=>'ro', isa=>'CodeRef');
+
+=head1 METHODS
+
+This class defines the following methods.
+
+=head2 generate_constraint_for ($type_constraints)
+
+Given some type constraints, use them to generate validation rules for an ref
+of values (to be passed at check time)
+
+=cut
+
+sub generate_constraint_for {
+ my ($self, $type_constraints) = @_;
+ return sub {
+ my $constraint_generator = $self->constraint_generator;
+ return $constraint_generator->($type_constraints, @_);
+ };
+}
+
+=head2 parameterize (@type_constraints)
+
+Given a ref of type constraints, create a structured type.
+
+=cut
+
+sub parameterize {
+ 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,
+ );
+}
+
+=head2 compile_type_constraint
+
+hook into compile_type_constraint so we can set the correct validation rules.
+
+=cut
+
+around 'compile_type_constraint' => sub {
+ my ($compile_type_constraint, $self, @args) = @_;
+
+ if($self->has_type_constraints) {
+ my $type_constraints = $self->type_constraints;
+ my $constraint = $self->generate_constraint_for($type_constraints);
+ $self->_set_constraint($constraint);
+ }
+
+ return $self->$compile_type_constraint(@args);
+};
+
+=head1 SEE ALSO
+
+The following modules or resources may be of interest.
+
+L<Moose>, L<Moose::Meta::TypeConstraint>
+
+=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
+++ /dev/null
-package MooseX::Meta::TypeConstraint::Structured::Generator;
-
-use strict;
-use warnings;
-
-use metaclass;
-
-use base 'Moose::Meta::TypeConstraint';
-use Moose::Util::TypeConstraints ();
-
-__PACKAGE__->meta->add_attribute('structured_type' => (
- accessor => 'structured_type',
- predicate => 'has_structured_type',
-));
-
-sub _parse_type_parameter {
- my ($self, $type_str) = @_;
- return $self->structured_type->_parse_type_parameter($type_str);
-}
-
-sub parameterize {
- my ($self, $parameter_string) = @_;
- my @contained_tcs = $self->_parse_type_parameter($parameter_string);
- my $tc_name = $self->name .'['. join(',', map {$_->name} @contained_tcs) .']';
-
- return $self->structured_type->new(
- name => $tc_name,
- parent => $self->parent,
- package_defined_in => __PACKAGE__,
- signature => \@contained_tcs,
- );
-}
-
-1;
+++ /dev/null
-package MooseX::Meta::TypeConstraint::Structured::Named;
-
-use Moose;
-use Moose::Meta::TypeConstraint ();
-
-extends 'Moose::Meta::TypeConstraint';
-with 'MooseX::Meta::TypeConstraint::Role::Structured';
-
-=head1 NAME
-
-MooseX::Meta::TypeConstraint::Structured::Named - Structured Type Constraints
-
-=head1 SYNOPSIS
-
-The follow is example usage:
-
- use Moose::Util::TypeConstraints;
- use MooseX::Meta::TypeConstraint::Structured::Named;
-
- my %required = (key1='Str', key2=>'Int');
- my %optional = (key3=>'Object');
-
- my $tc = MooseX::Meta::TypeConstraint::Structured::Named->new(
- name => 'Dict',
- parent => find_type_constraint('HashRef'),
- package_defined_in => __PACKAGE__,
- signature => {map {
- $_ => find_type_constraint($required{$_});
- } keys %required},
- optional_signature => {map {
- $_ => find_type_constraint($optional{$_});
- } keys %optional},
- );
-
-=head1 DESCRIPTION
-
-Named structured Constraints expect the internal constraints to be in keys or
-fields similar to what we expect in a HashRef. Basically, this allows you to
-easily add type constraint checks against values in the wrapping HashRef
-identified by the key name.
-
-=head1 ATTRIBUTES
-
-This class defines the following attributes.
-
-=head2 signature
-
-This is a signature of internal contraints for the contents of the outer
-contraint container.
-
-=cut
-
-has '+signature' => (isa=>'HashRef[Moose::Meta::TypeConstraint]');
-
-=head2 optional_signature
-
-This is a signature of internal contraints for the contents of the outer
-contraint container. These are optional constraints.
-
-=cut
-
-has '+optional_signature' => (isa=>'HashRef[Moose::Meta::TypeConstraint]');
-
-=head1 METHODS
-
-This class defines the following methods.
-
-=head2 _normalize_args
-
-Get arguments into a known state or die trying. Ideally we try to make this
-into a HashRef so we can match it up with the L</signature> HashRef.
-
-=cut
-
-sub _normalize_args {
- my ($self, $args) = @_;
- if(defined $args) {
- if(ref $args eq 'HASH') {
- %$args
- } else {
- confess 'Signature must be an HashRef type';
- }
- } else {
- confess 'Signature cannot be empty';
- }
-}
-
-=head2 constraint
-
-The constraint is basically validating the L</signature> against the incoming
-
-=cut
-
-sub constraint {
- my $self = shift;
- return sub {
- my %args = $self->_normalize_args(shift);
-
- ## First make sure all the required type constraints match
- foreach my $sig_key (keys %{$self->signature}) {
- my $type_constraint = $self->signature->{$sig_key};
- if(my $error = $type_constraint->validate($args{$sig_key})) {
- confess $error;
- } else {
- delete $args{$sig_key};
- }
- }
-
- ## Now test the option type constraints.
- foreach my $arg_key (keys %args) {
- my $optional_type_constraint = $self->optional_signature->{$arg_key};
- if(my $error = $optional_type_constraint->validate($args{$arg_key})) {
- confess $error;
- }
- }
-
- ## If we got this far we passed!
- return 1;
- };
-}
-
-=head2 signature_equals
-
-Check that the signature equals another signature.
-
-=cut
-
-sub signature_equals {
- my ($self, $compared_type_constraint) = @_;
-
- foreach my $idx (keys %{$self->signature}) {
- my $this = $self->signature->{$idx};
- my $that = $compared_type_constraint->signature->{$idx};
- return unless $this->equals($that);
- }
-
- if($self->has_optional_signature) {
- foreach my $idx (keys %{$self->optional_signature}) {
- my $this = $self->optional_signature->{$idx};
- my $that = $compared_type_constraint->optional_signature->{$idx};
- return unless $this->equals($that);
- }
- }
-
- return 1;
-}
-
-
-
-=head1 AUTHOR
-
-John James Napiorkowski <jjnapiork@cpan.org>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-no Moose; 1;
+++ /dev/null
-package MooseX::Meta::TypeConstraint::Structured::Optional;
-
-use Moose;
-use Moose::Meta::TypeConstraint ();
-
-#extends 'Moose::Meta::TypeConstraint';
-extends 'MooseX::Meta::TypeConstraint::Structured::Positional';
-with 'MooseX::Meta::TypeConstraint::Role::Structured';
-
-=head1 NAME
-
-MooseX::Meta::TypeConstraint::Structured::Optional - Structured Type Constraints
-
-=head1 SYNOPSIS
-
-The follow is example usage:
-
- use Moose::Util::TypeConstraints;
- use MooseX::Meta::TypeConstraint::Structured::Optional;
-
- my @options = ('Str', 'Int');
-
- my $tc = MooseX::Meta::TypeConstraint::Structured::Optional->new(
- name => 'Dict',
- parent => find_type_constraint('ArrayRef'),
- signature => [map {
- find_type_constraint($_);
- } @options],
- );
-
-=head1 DESCRIPTION
-
-Optional Type Constraints are additional constraints on a 'base' structured
-type constraint which extends those constraints with additional optional
-fields. Basically this constraint get's it's constraint logic and args
-from a a Structured Type Constraint that contains it. So basically:
-
- MyType[Int,Str,Optional[Int, Int]]
-
-In this example, the structured Type constraint 'MyType' is the container for
-this Optional type called 'Optional'. What will happen here is that the
-MyType will get the first elements for validation and a third one will go
-to optional. Optional will 'inline' itself so that you can validate with:
-
- ->validate(1,'hello',2,3);
- ->validate(1,'hello',2);
- ->validate(1,'hello');
-
-and not:
-
- ->validate(1,'hello',[2,3]]);
- ->validate(1,'hello',[2]]);
-
-as you might expect. Basically it sucks up args to the length of it's declared
-type constraints. So Optional args are validated against the definition, but if
-they are missing this does not cause a validation error.
-
-Please keep in mind the type constraint names given in this example are for
-example use only and any similarity between them, actual Type Constraints and
-package names are coincidental.
-
-=head1 ATTRIBUTES
-
-This class defines the following attributes.
-
-=head2 containing_type_constraint ($structured_type_constraint)
-
-This is the type constraint that contains the Optional parameters.
-
-=cut
-
-#has 'containing_type_constraint' => (
-# is=>'ro',
-# does=>'MooseX::Meta::TypeConstraint::Role::Structured',
-# required=>1,
-#);
-
-=head2 signature
-
-This is a signature of internal contraints for the contents of the outer
-contraint container.
-
-=cut
-
-has '+signature' => (isa=>'ArrayRef[Moose::Meta::TypeConstraint]');
-
-=head1 METHODS
-
-This class defines the following methods.
-
-=head2 _normalize_args
-
-Get arguments into a known state or die trying. Ideally we try to make this
-into a HashRef so we can match it up with the L</signature> HashRef. This gets
-delegated to the containing class (L</containing_type_constraint>).
-
-=cut
-
-#sub _normalize_args {
-# return shift->containing_type_constraint->_normalize_args(@_);
-#}
-
-=head2 constraint
-
-The constraint is basically validating the L</signature> against the incoming
-
-=cut
-
-#sub constraint {
-# return 1;
- # return shift->containing_type_constraint->constraint(@_);
-#}
-
-=head2 _parse_type_parameter ($str)
-
-Given a $string that is the parameter information part of a parameterized
-constraint, parses it for internal constraint information. This is delegated
-to the containing class.
-
-=cut
-
-#sub _parse_type_parameter {
-# return shift->containing_type_constraint->_parse_type_parameter(@_);
-#}
-
-
-=head2 signature_equals
-
-Check that the signature equals another signature. Delegated to the containing
-class.
-
-=cut
-
-#sub signature_equals {
-# return shift->containing_type_constraint->signature_equals(@_);
-#}
-
-=head1 AUTHOR
-
-John James Napiorkowski <jjnapiork@cpan.org>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-no Moose; 1;
+++ /dev/null
-package MooseX::Meta::TypeConstraint::Structured::Positional;
-
-use Moose;
-use Moose::Meta::TypeConstraint ();
-
-extends 'Moose::Meta::TypeConstraint';
-with 'MooseX::Meta::TypeConstraint::Role::Structured';
-
-=head1 NAME
-
-MooseX::Meta::TypeConstraint::Structured::Positional - Structured Type Constraints
-
-=head1 SYNOPSIS
-
-The follow is example usage:
-
- use Moose::Util::TypeConstraints;
- use MooseX::Meta::TypeConstraint::Structured::Positional;
-
- my @required = ('Str', 'Int');
- my @optional = ('Object');
-
- my $tc = MooseX::Meta::TypeConstraint::Structured::Positional->new(
- name => 'Dict',
- parent => find_type_constraint('ArrayRef'),
- signature => [map {
- find_type_constraint($_);
- } @required],
- optional_signature => [map {
- find_type_constraint($_);
- } @optional],
- );
-
-=head1 DESCRIPTION
-
-Positionally structured Constraints expect the internal constraints to be in
-'positioned' or ArrayRef style order. This allows you to add type constraints
-to the internal values of the Arrayref.
-
-=head1 ATTRIBUTES
-
-This class defines the following attributes.
-
-=head2 signature
-
-This is a signature of internal contraints for the contents of the outer
-contraint container.
-
-=cut
-
-has '+signature' => (isa=>'ArrayRef[Moose::Meta::TypeConstraint]');
-
-=head2 optional_signature
-
-This is a signature of internal contraints for the contents of the outer
-contraint container. These are optional constraints.
-
-=cut
-
-has '+optional_signature' => (isa=>'ArrayRef[Moose::Meta::TypeConstraint]');
-
-=head1 METHODS
-
-This class defines the following methods.
-
-=head2 _normalize_args
-
-Get arguments into a known state or die trying. Ideally we try to make this
-into a HashRef so we can match it up with the L</signature> HashRef.
-
-=cut
-
-sub _normalize_args {
- my ($self, $args) = @_;
- if(defined $args) {
- if(ref $args eq 'ARRAY') {
- @$args
- } else {
- confess 'Signature must be an ArrayRef type';
- }
- } else {
- confess 'Signature cannot be empty';
- }
-}
-
-=head2 constraint
-
-The constraint is basically validating the L</signature> against the incoming
-
-=cut
-
-sub constraint {
- my $self = shift;
- return sub {
- my @args = $self->_normalize_args(shift);
- my @signature = @{$self->signature};
- my @optional_signature = @{$self->optional_signature}
- if $self->has_optional_signature;
-
- ## First make sure all the required type constraints match
- while( my $type_constraint = shift @signature) {
- if(my $error = $type_constraint->validate(shift @args)) {
- confess $error;
- }
- }
-
- ## Now test the option type constraints.
- while( my $arg = shift @args) {
- if(my $optional_type_constraint = shift @optional_signature) {
- if(my $error = $optional_type_constraint->validate($arg)) {
- confess $error;
- }
- } else {
- confess "Too Many arguments for the available type constraints";
- }
- }
-
- ## If we got this far we passed!
- return 1;
- };
-}
-
-=head2 signature_equals
-
-Check that the signature equals another signature.
-
-=cut
-
-sub signature_equals {
- my ($self, $compared_type_constraint) = @_;
-
- foreach my $idx (0..$#{$self->signature}) {
- my $this = $self->signature->[$idx];
- my $that = $compared_type_constraint->signature->[$idx];
- return unless $this->equals($that);
- }
-
- if($self->has_optional_signature) {
- foreach my $idx (0..$#{$self->optional_signature}) {
- my $this = $self->optional_signature->[$idx];
- my $that = $compared_type_constraint->optional_signature->[$idx];
- return unless $this->equals($that);
- }
- }
-
- return 1;
-}
-
-=head1 AUTHOR
-
-John James Napiorkowski <jjnapiork@cpan.org>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-no Moose; 1;
use Moose;
use Moose::Util::TypeConstraints;
-use MooseX::Meta::TypeConstraint::Structured::Positional;
-use MooseX::Meta::TypeConstraint::Structured::Named;
+use MooseX::Meta::TypeConstraint::Structured;
+use MooseX::Types -declare => [qw(Dict Tuple)];
-#use MooseX::Types -declare => [qw(Dict Tuple Optional)];
-use Sub::Exporter
- -setup => { exports => [ qw( Dict Tuple Optional) ] };
our $VERSION = '0.01';
our $AUTHORITY = 'cpan:JJNAPIORK';
};
-=head1 TYPES
+=head1 METHODS
-This class defines the following types and subtypes.
+This class defines the following methods
-=cut
+=head2 type_storage
-sub Optional($) {
- return bless {args=>shift}, 'MooseX::Types::Optional';
-}
+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.
-sub Tuple($) {
- my ($args, $optional) = _normalize_args(@_);
- my @args = @$args;
- my @optional = ref $optional eq 'ARRAY' ? @$optional : ();
-
- return MooseX::Meta::TypeConstraint::Structured::Positional->new(
- name => 'Tuple',
- parent => find_type_constraint('ArrayRef'),
- package_defined_in => __PACKAGE__,
- signature => [map {
- _normalize_type_constraint($_);
- } @args],
- optional_signature => [map {
- _normalize_type_constraint($_);
- } @optional],
- );
-}
-use Data::Dump qw/dump/;
-sub Dict($) {
- my ($args, $optional) = _normalize_args(@_);
- my %args = @$args;
- my %optional = ref $optional eq 'ARRAY' ? @$optional : ();
-
-
- return MooseX::Meta::TypeConstraint::Structured::Named->new(
- name => 'Dict',
- parent => find_type_constraint('HashRef'),
- package_defined_in => __PACKAGE__,
- signature => {map {
- $_ => _normalize_type_constraint($args{$_});
- } keys %args},
- optional_signature => {map {
-
- warn dump $_;
- warn dump $optional{$_};
- warn dump _normalize_type_constraint($optional{$_});
-
- $_ => _normalize_type_constraint($optional{$_});
-
- } keys %optional},
- );
-}
+In the future, might make all these play more nicely with Parameterized types,
+and then this nasty override can go away.
-sub _normalize_args {
- my $args = shift @_;
- confess "Structured Type Constraints can only accept an ArrayRef as arguments"
- unless ref $args eq 'ARRAY';
-
- my @args = @$args;
- my $last = pop @args;
-
- if(blessed $last && $last->isa('MooseX::Types::Optional')) {
- return ([@args], $last->{args});
- } else {
- return ([@args, $last]);
- }
-
-}
-sub _normalize_type_constraint {
- my ($tc) = @_;
-
- ## If incoming is an object, we will assume it's something that implements
- ## what a type constraint is. We should probably have a Role for this...
- if(defined $tc && blessed $tc) {
- return $tc;
- } elsif($tc) {
- return Moose::Util::TypeConstraints::find_or_parse_type_constraint($tc);
- }
+=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.
+ if(@values) {
+ 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 {
+ return;
+ }
+ }
+ ## Make sure there are no leftovers.
+ if(%values) {
+ return;
+ } elsif(%type_constraints) {
+ return;
+ }else {
+ return 1;
+ }
+ },
+ ),
+ };
}
=head1 SEE ALSO
The following modules or resources may be of interest.
-L<Moose>, L<MooseX::TypeLibrary>, L<Moose::Meta::TypeConstraint>
-
-=head1 BUGS
-
-No known or reported bugs.
+L<Moose>, L<MooseX::TypeLibrary>, L<Moose::Meta::TypeConstraint>,
+L<MooseX::Meta::TypeConstraint::Structured>
=head1 AUTHOR
use strict;
use warnings;
-use Test::More tests=>5;
+use Test::More tests=>2;
## List all the modules we want to make sure can at least compile
-
-use_ok 'MooseX::Meta::TypeConstraint::Structured::Named';
-use_ok 'MooseX::Meta::TypeConstraint::Structured::Positional';
-use_ok 'MooseX::Meta::TypeConstraint::Structured::Optional';
-use_ok 'MooseX::Meta::TypeConstraint::Structured::Generator';
+use_ok 'MooseX::Meta::TypeConstraint::Structured';
use_ok 'MooseX::Types::Structured';
\ No newline at end of file
-BEGIN {
- use strict;
- use warnings;
- use Test::More tests=>37;
- use Test::Exception;
-
- use_ok 'Moose::Util::TypeConstraints';
- use_ok 'MooseX::Meta::TypeConstraint::Structured::Generator';
- use_ok 'MooseX::Meta::TypeConstraint::Structured::Positional';
- use_ok 'MooseX::Meta::TypeConstraint::Structured::Optional';
- use_ok 'MooseX::Meta::TypeConstraint::Structured::Named';
-}
-
-my $optional = MooseX::Meta::TypeConstraint::Structured::Generator->new(
- name => 'Optional',
- structured_type => 'MooseX::Meta::TypeConstraint::Structured::Optional',
- package_defined_in => __PACKAGE__,
- parent => find_type_constraint('ArrayRef'),
- );
-
-my $tuple = MooseX::Meta::TypeConstraint::Structured::Generator->new(
- name => 'Tuple',
- structured_type => 'MooseX::Meta::TypeConstraint::Structured::Positional',
- package_defined_in => __PACKAGE__,
- parent => find_type_constraint('ArrayRef'),
- );
-
-my $dict = MooseX::Meta::TypeConstraint::Structured::Generator->new(
- name => 'Dict',
- structured_type => 'MooseX::Meta::TypeConstraint::Structured::Named',
- package_defined_in => __PACKAGE__,
- parent => find_type_constraint('HashRef'),
- );
-
-Moose::Util::TypeConstraints::register_type_constraint($optional);
-Moose::Util::TypeConstraints::register_type_constraint($tuple);
-Moose::Util::TypeConstraints::register_type_constraint($dict);
-
-## Make sure the new type constraints have been registered
-
-ok Moose::Util::TypeConstraints::find_type_constraint('Tuple')
- => 'Found the Tuple Type';
-
-ok Moose::Util::TypeConstraints::find_type_constraint('Dict')
- => 'Found the Tuple Type';
-
-ok Moose::Util::TypeConstraints::find_type_constraint('Optional')
- => 'Found the Tuple Type';
-
-{
- package Test::MooseX::Types::Structured::BasicAttributes;
-
- use Moose;
- use Moose::Util::TypeConstraints;
-
- has 'tuple' => (is=>'rw', isa=>'Tuple[Int,Str,Int]');
- has 'tuple_with_parameterized' => (is=>'rw', isa=>'Tuple[Int,Str,Int,ArrayRef[Int]]');
- has 'tuple_with_optional' => (is=>'rw', isa=>'Tuple[Int,Str,Int,Optional[Int,Int]]');
- has 'tuple_with_union' => (is=>'rw', isa=>'Tuple[Int,Str,Int|Object,Optional[Int|Object,Int]]');
-
- has 'dict' => (is=>'rw', isa=>'Dict[name=>Str,age=>Int]');
- has 'dict_with_parameterized' => (is=>'rw', isa=>'Dict[name=>Str, age=>Int, telephone=>ArrayRef[Int]]');
- has 'dict_with_optional' => (is=>'rw', isa=>'Dict[name=>Str, age=>Int, Optional[opt1=>Str,opt2=>Object]]');
-
-}
-
-
-ok my $obj = Test::MooseX::Types::Structured::BasicAttributes->new,
- => 'Got a good object';
-
-ok Moose::Util::TypeConstraints::find_type_constraint('Tuple[Int,Str,Int]')
- => 'Found expected type constraint';
-
-ok Moose::Util::TypeConstraints::find_type_constraint('Tuple[Int,Str,Int,Optional[Int,Int]]')
- => 'Found expected type constraint';
-
-## dict Dict[name=>Str, Age=>Int]
-
-ok $obj->dict({name=>'John', age=>39})
- => 'Dict[name=>Str, Age=>Int] properly succeeds';
-
-
-
-
-
-
-## Test tuple (Tuple[Int,Str,Int])
-
-ok $obj->tuple([1,'hello',3])
- => "[1,'hello',3] properly suceeds";
-
-throws_ok sub {
- $obj->tuple([1,2,'world']);
-}, qr/Validation failed for 'Int' failed with value world/ => "[1,2,'world'] properly fails";
-
-throws_ok sub {
- $obj->tuple(['hello1',2,3]);
-}, qr/Validation failed for 'Int' failed with value hello1/ => "['hello',2,3] properly fails";
-
-throws_ok sub {
- $obj->tuple(['hello2',2,'world']);
-}, qr/Validation failed for 'Int' failed with value hello2/ => "['hello',2,'world'] properly fails";
-
-
-## Test tuple_with_parameterized (Tuple[Int,Str,Int,ArrayRef[Int]])
-
-ok $obj->tuple_with_parameterized([1,'hello',3,[1,2,3]])
- => "[1,'hello',3,[1,2,3]] properly suceeds";
-
-throws_ok sub {
- $obj->tuple_with_parameterized([1,2,'world']);
-}, qr/Validation failed for 'Int' failed with value world/ => "[1,2,'world'] properly fails";
-
-throws_ok sub {
- $obj->tuple_with_parameterized(['hello1',2,3]);
-}, qr/Validation failed for 'Int' failed with value hello1/ => "['hello',2,3] properly fails";
-
-throws_ok sub {
- $obj->tuple_with_parameterized(['hello2',2,'world']);
-}, qr/Validation failed for 'Int' failed with value hello2/ => "['hello',2,'world'] properly fails";
-
-throws_ok sub {
- $obj->tuple_with_parameterized([1,'hello',3,[1,2,'world']]);
-}, qr/Validation failed for 'ArrayRef\[Int\]'/ => "[1,'hello',3,[1,2,'world']] properly fails";
-
-
-## Test tuple_with_optional (Tuple[Int,Str,Int,Optional[Int,Int]])
-
-ok $obj->tuple_with_optional([1,'hello',3])
- => "[1,'hello',3] properly suceeds";
-
-ok $obj->tuple_with_optional([1,'hello',3,1])
- => "[1,'hello',3,1] properly suceeds";
-
-ok $obj->tuple_with_optional([1,'hello',3,4])
- => "[1,'hello',3,4] properly suceeds";
-
-ok $obj->tuple_with_optional([1,'hello',3,4,5])
- => "[1,'hello',3,4,5] properly suceeds";
-
-throws_ok sub {
- $obj->tuple_with_optional([1,'hello',3,4,5,6]);
-}, qr/Too Many arguments for the available type constraints/ => "[1,'hello',3,4,5,6] properly fails";
-
-throws_ok sub {
- $obj->tuple_with_optional([1,2,'world']);
-}, qr/Validation failed for 'Int' failed with value world/ => "[1,2,'world'] properly fails";
-
-throws_ok sub {
- $obj->tuple_with_optional(['hello1',2,3]);
-}, qr/Validation failed for 'Int' failed with value hello1/ => "['hello',2,3] properly fails";
-
-throws_ok sub {
- $obj->tuple_with_optional(['hello2',2,'world']);
-}, qr/Validation failed for 'Int' failed with value hello2/ => "['hello',2,'world'] properly fails";
-
-## tuple_with_union Tuple[Int,Str,Int|Object,Optional[Int|Object,Int]]
-
-SKIP: {
-
- skip "Unions not supported for string parsed type constraints" => 8;
-
- ok $obj->tuple_with_union([1,'hello',3])
- => "[1,'hello',3] properly suceeds";
-
- ok $obj->tuple_with_union([1,'hello',3,1])
- => "[1,'hello',3,1] properly suceeds";
-
- ok $obj->tuple_with_union([1,'hello',3,4])
- => "[1,'hello',3,4] properly suceeds";
-
- ok $obj->tuple_with_union([1,'hello',3,4,5])
- => "[1,'hello',3,4,5] properly suceeds";
-
- throws_ok sub {
- $obj->tuple_with_union([1,'hello',3,4,5,6]);
- }, qr/Too Many arguments for the available type constraints/ => "[1,'hello',3,4,5,6] properly fails";
-
- throws_ok sub {
- $obj->tuple_with_union([1,2,'world']);
- }, qr/Validation failed for 'Int' failed with value world/ => "[1,2,'world'] properly fails";
-
- throws_ok sub {
- $obj->tuple_with_union(['hello1',2,3]);
- }, qr/Validation failed for 'Int' failed with value hello1/ => "['hello',2,3] properly fails";
-
- throws_ok sub {
- $obj->tuple_with_union(['hello2',2,'world']);
- }, qr/Validation failed for 'Int' failed with value hello2/ => "['hello',2,'world'] properly fails";
-}
-
+use strict;
+use warnings;
+
+use Test::More tests=>14;
+
+use_ok 'MooseX::Meta::TypeConstraint::Structured';
+use_ok 'Moose::Util::TypeConstraints';
+
+ok my $int = find_type_constraint('Int') => 'Got Int';
+ok my $str = find_type_constraint('Str') => 'Got Str';
+ok my $arrayref = find_type_constraint('ArrayRef') => 'Got ArrayRef';
+
+my $list_tc = MooseX::Meta::TypeConstraint::Structured->new(
+ name => 'list_tc',
+ parent => $arrayref,
+ type_constraints => [$int, $str],
+ constraint_generator=> sub {
+ my @type_constraints = @{shift @_};
+ my @values = @{shift @_};
+
+ while(my $type_constraint = shift @type_constraints) {
+ my $value = shift @values || return;
+ $type_constraint->check($value) || return;
+ }
+ if(@values) {
+ return;
+ } else {
+ return 1;
+ }
+ }
+);
+
+isa_ok $list_tc, 'MooseX::Meta::TypeConstraint::Structured';
+
+ok !$arrayref->check() => 'Parent undef fails';
+ok !$list_tc->check() => 'undef fails';
+ok !$list_tc->check(1) => '1 fails';
+ok !$list_tc->check([]) => '[] fails';
+ok !$list_tc->check([1]) => '[1] fails';
+ok !$list_tc->check([1,2,3]) => '[1,2,3] fails';
+ok !$list_tc->check(['a','b']) => '["a","b"] fails';
+
+ok $list_tc->check([1,'a']) => '[1,"a"] passes';
+++ /dev/null
-BEGIN {
- use strict;
- use warnings;
- use Test::More tests=>47;
- use Test::Exception;
-}
-
-{
- package Test::MooseX::Meta::TypeConstraint::Structured;
-
- use Moose;
- use MooseX::Types::Structured qw(Tuple Dict Optional);
- use MooseX::Types::Moose qw(Int Str Object ArrayRef HashRef Maybe);
- use MooseX::Types -declare => [qw(MyString)];
- use Moose::Util::TypeConstraints;
-
- subtype MyString,
- as 'Str',
- where { $_=~m/abc/};
-
- has 'tuple' => (is=>'rw', isa=>Tuple[Int, Str, MyString]);
- has 'dict' => (is=>'rw', isa=>Dict[name=>Str, age=>Int]);
- has 'dict_with_maybe' => (is=>'rw', isa=>Dict[name=>Str, age=>Maybe[Int]]);
- has 'tuple_with_param' => (is=>'rw', isa=>Tuple[Int, Str, ArrayRef[Int]]);
- has 'tuple_with_maybe' => (is=>'rw', isa=>Tuple[Int, Str, Maybe[Int]]);
- has 'dict_with_tuple' => (is=>'rw', isa=>Dict[key1=>Str, key2=>Tuple[Int,Str]]);
- has 'optional_tuple' => (is=>'rw', isa=>Tuple[Int, Int, Optional[Int]] );
- has 'optional_dict' => (is=>'rw', isa=>Dict[key1=>Int, Optional[key2=>Int]] );
- has 'dict_with_tuple_with_union' => (is=>'rw', isa=>Dict[key1=>Str|Object, key2=>Tuple[Int,Str|Object]] );
-
- has 'crazy' => (
- is=>'rw',
- isa=>Tuple
- ## First ArrayRef Arg is the required type constraints for the top
- ## level Tuple.
- [
- Int,
- MyString,
- ## The third required element is a Dict type constraint, which
- ## itself has two required keys and a third optional key.
- Dict[name=>Str,age=>Int, Optional[visits=>Int]],
- Optional[
- Int,
- ## This Tuple has one required type constraint and two optional.
- Tuple[Int, Optional[Int,HashRef]],
- ],
- ],
- );
-}
-
-## Instantiate a new test object
-
-ok my $record = Test::MooseX::Meta::TypeConstraint::Structured->new
- => 'Instantiated new Record test class.';
-
-isa_ok $record => 'Test::MooseX::Meta::TypeConstraint::Structured'
- => 'Created correct object type.';
-
-## Test crazy
-
-lives_ok sub {
- $record->crazy([1,'hello.abc.world', {name=>'John', age=>39}]);
-} => 'Set crazy attribute with no optionals used';
-
-is_deeply $record->crazy, [1, 'hello.abc.world', {name=>'John', age=>39}]
- => 'correct values for crazy attributes no optionals';
-
-lives_ok sub {
- $record->crazy([1,'hello.abc.world', {name=>'John', age=>39, visits=>10},10, [1,2,{key=>'value'}]]);
-} => 'Set crazy attribute with all optionals used';
-
-is_deeply $record->crazy, [1,'hello.abc.world', {name=>'John', age=>39, visits=>10},10, [1,2,{key=>'value'}]]
- => 'correct values for crazy attributes all optionals';
-
-lives_ok sub {
- $record->crazy([1,'hello.abc.world', {name=>'John', age=>39},10, [1,2]]);
-} => 'Set crazy attribute with some optionals used';
-
-throws_ok sub {
- $record->crazy([1,'hello', 'test.xxx.test']);
-}, qr/Validation failed for 'MyString'/
- => 'Properly failed for bad value in crazy attribute 01';
-
-throws_ok sub {
- $record->crazy([1,'hello.abc.world', {notname=>'John', notage=>39}]);
-}, qr/Validation failed for 'Str'/
- => 'Properly failed for bad value in crazy attribute 02';
-
-## Test Tuple type constraint
-
-lives_ok sub {
- $record->tuple([1,'hello', 'test.abc.test']);
-} => 'Set tuple attribute without error';
-
-is $record->tuple->[0], 1
- => 'correct set the tuple attribute index 0';
-
-is $record->tuple->[1], 'hello'
- => 'correct set the tuple attribute index 1';
-
-is $record->tuple->[2], 'test.abc.test'
- => 'correct set the tuple attribute index 2';
-
-throws_ok sub {
- $record->tuple([1,'hello', 'test.xxx.test']);
-}, qr/Validation failed for 'MyString'/
- => 'Properly failed for bad value in custom type constraint';
-
-throws_ok sub {
- $record->tuple(['asdasd',2, 'test.abc.test']);
-}, qr/Validation failed for 'Int'/
- => 'Got Expected Error for violating constraints';
-
-## Test the Dictionary type constraint
-
-lives_ok sub {
- $record->dict({name=>'frith', age=>23});
-} => 'Set dict attribute without error';
-
-is $record->dict->{name}, 'frith'
- => 'correct set the dict attribute name';
-
-is $record->dict->{age}, 23
- => 'correct set the dict attribute age';
-
-throws_ok sub {
- $record->dict({name=>[1,2,3], age=>'sdfsdfsd'});
-}, qr/Validation failed for 'Str'/
- => 'Got Expected Error for bad value in dict';
-
-## Test tuple_with_maybe
-
-lives_ok sub {
- $record->tuple_with_maybe([1,'hello', 1]);
-} => 'Set tuple attribute without error';
-
-throws_ok sub {
- $record->tuple_with_maybe([1,'hello', 'a']);
-}, qr/Validation failed for 'Maybe\[Int\]'/
- => 'Properly failed for bad value parameterized constraint';
-
-lives_ok sub {
- $record->tuple_with_maybe([1,'hello']);
-} => 'Set tuple attribute without error skipping optional parameter';
-
-## Test Tuple with parameterized type
-
-lives_ok sub {
- $record->tuple_with_param([1,'hello', [1,2,3]]);
-} => 'Set tuple attribute without error';
-
-throws_ok sub {
- $record->tuple_with_param([1,'hello', [qw/a b c/]]);
-}, qr/Validation failed for 'ArrayRef\[Int\]'/
- => 'Properly failed for bad value parameterized constraint';
-
-## Test dict_with_maybe
-
-lives_ok sub {
- $record->dict_with_maybe({name=>'frith', age=>23});
-} => 'Set dict attribute without error';
-
-is $record->dict_with_maybe->{name}, 'frith'
- => 'correct set the dict attribute name';
-
-is $record->dict_with_maybe->{age}, 23
- => 'correct set the dict attribute age';
-
-throws_ok sub {
- $record->dict_with_maybe({name=>[1,2,3], age=>'sdfsdfsd'});
-}, qr/Validation failed for 'Str'/
- => 'Got Expected Error for bad value in dict';
-
-throws_ok sub {
- $record->dict_with_maybe({age=>30});
-}, qr/Validation failed for 'Str'/
- => 'Got Expected Error for missing named parameter';
-
-lives_ok sub {
- $record->dict_with_maybe({name=>'usal'});
-} => 'Set dict attribute without error, skipping optional';
-
-## Test dict_with_tuple
-
-lives_ok sub {
- $record->dict_with_tuple({key1=>'Hello', key2=>[1,'World']});
-} => 'Set tuple attribute without error';
-
-throws_ok sub {
- $record->dict_with_tuple({key1=>'Hello', key2=>['World',2]});
-}, qr/Validation failed for 'Int'/
- => 'Threw error on bad constraint';
-
-## Test optional_tuple
-
-lives_ok sub {
- $record->optional_tuple([1,2,3]);
-} => 'Set tuple attribute with optional bits';
-
-is_deeply $record->optional_tuple, [1,2,3]
- => 'correct values set';
-
-lives_ok sub {
- $record->optional_tuple([4,5]);
-} => 'Set tuple attribute withOUT optional bits';
-
-is_deeply $record->optional_tuple, [4,5]
- => 'correct values set again';
-
-throws_ok sub {
- $record->optional_tuple([1,2,'bad']);
-}, qr/Validation failed for 'Int'/
- => 'Properly failed for bad value in optional bit';
-
-# Test optional_dict
-
-lives_ok sub {
- $record->optional_dict({key1=>1,key2=>2});
-} => 'Set tuple attribute with optional bits';
-
-is_deeply $record->optional_dict, {key1=>1,key2=>2}
- => 'correct values set';
-
-lives_ok sub {
- $record->optional_dict({key1=>3});
-} => 'Set tuple attribute withOUT optional bits';
-
-is_deeply $record->optional_dict, {key1=>3}
- => 'correct values set again';
-
-throws_ok sub {
- $record->optional_dict({key1=>1,key2=>'bad'});
-}, qr/Validation failed for 'Int'/
- => 'Properly failed for bad value in optional bit';
-
-
-## Test dict_with_tuple_with_union: Dict[key1=>'Str|Object', key2=>Tuple['Int','Str|Object']]
-
-lives_ok sub {
- $record->dict_with_tuple_with_union({key1=>'Hello', key2=>[1,'World']});
-} => 'Set tuple attribute without error';
-
-throws_ok sub {
- $record->dict_with_tuple_with_union({key1=>'Hello', key2=>['World',2]});
-}, qr/Validation failed for 'Int'/
- => 'Threw error on bad constraint';
-
-lives_ok sub {
- $record->dict_with_tuple_with_union({key1=>$record, key2=>[1,'World']});
-} => 'Set tuple attribute without error';
-
-lives_ok sub {
- $record->dict_with_tuple_with_union({key1=>'Hello', key2=>[1,$record]});
-} => 'Set tuple attribute without error';
-
-throws_ok sub {
- $record->dict_with_tuple_with_union({key1=>1, key2=>['World',2]});
-}, qr/Validation failed for 'Int'/
- => 'Threw error on bad constraint';
--- /dev/null
+BEGIN {
+ use strict;
+ use warnings;
+ use Test::More tests=>26;
+ use Test::Exception;
+}
+
+{
+ package Test::MooseX::Meta::TypeConstraint::Structured::Tuple;
+
+ use Moose;
+ use MooseX::Types::Structured qw(Tuple);
+ use MooseX::Types::Moose qw(Int Str Object ArrayRef HashRef Maybe);
+ use MooseX::Types -declare => [qw(MyString)];
+
+ subtype MyString,
+ as 'Str',
+ where { $_=~m/abc/};
+
+ #use Data::Dump qw/dump/; warn dump Tuple;
+
+ has 'tuple' => (is=>'rw', isa=>Tuple[Int, Str, MyString]);
+ has 'tuple_with_param' => (is=>'rw', isa=>Tuple[Int, Str, ArrayRef[Int]]);
+ has 'tuple_with_maybe' => (is=>'rw', isa=>Tuple[Int, Str, Maybe[Int], Object]);
+ has 'tuple_with_maybe2' => (is=>'rw', isa=>Tuple[Int, Str, Maybe[Int]]);
+ has 'tuple_with_union' => (is=>'rw', isa=>Tuple[Int,Str,Int|Object,Int]);
+ has 'tuple2' => (is=>'rw', isa=>Tuple[Int,Str,Int]);
+ has 'tuple_with_parameterized' => (is=>'rw', isa=>Tuple[Int,Str,Int,ArrayRef[Int]]);
+}
+
+## Instantiate a new test object
+
+ok my $record = Test::MooseX::Meta::TypeConstraint::Structured::Tuple->new
+ => 'Instantiated new Record test class.';
+
+isa_ok $record => 'Test::MooseX::Meta::TypeConstraint::Structured::Tuple'
+ => 'Created correct object type.';
+
+## Test Tuple type constraint
+
+lives_ok sub {
+ $record->tuple([1,'hello', 'test.abc.test']);
+} => 'Set tuple attribute without error';
+
+is $record->tuple->[0], 1
+ => 'correct set the tuple attribute index 0';
+
+is $record->tuple->[1], 'hello'
+ => 'correct set the tuple attribute index 1';
+
+is $record->tuple->[2], 'test.abc.test'
+ => 'correct set the tuple attribute index 2';
+
+throws_ok sub {
+ $record->tuple([1,'hello', 'test.xxx.test']);
+}, qr/Attribute \(tuple\) does not pass the type constraint/
+ => 'Properly failed for bad value in custom type constraint';
+
+throws_ok sub {
+ $record->tuple(['asdasd',2, 'test.abc.test']);
+}, qr/Attribute \(tuple\) does not pass the type constraint/
+ => 'Got Expected Error for violating constraints';
+
+## Test tuple_with_maybe
+
+lives_ok sub {
+ $record->tuple_with_maybe([1,'hello', 1, $record]);
+} => 'Set tuple attribute without error';
+
+throws_ok sub {
+ $record->tuple_with_maybe([1,'hello', 'a', $record]);
+}, qr/Attribute \(tuple_with_maybe\) does not pass the type constraint/
+ => 'Properly failed for bad value parameterized constraint';
+
+lives_ok sub {
+ $record->tuple_with_maybe([1,'hello',undef, $record]);
+} => 'Set tuple attribute without error skipping optional parameter';
+
+## Test tuple_with_maybe2
+
+lives_ok sub {
+ $record->tuple_with_maybe2([1,'hello', 1]);
+} => 'Set tuple attribute without error';
+
+throws_ok sub {
+ $record->tuple_with_maybe2([1,'hello', 'a']);
+}, qr/Attribute \(tuple_with_maybe2\) does not pass the type constraint/
+ => 'Properly failed for bad value parameterized constraint';
+
+lives_ok sub {
+ $record->tuple_with_maybe2([1,'hello',undef]);
+} => 'Set tuple attribute without error skipping optional parameter';
+
+throws_ok sub {
+ $record->tuple_with_maybe2([1,'hello']);
+}, qr/Attribute \(tuple_with_maybe2\) does not pass the type constraint/
+ => 'Properly fails for missing maybe (needs to be at least undef)';
+
+## Test Tuple with parameterized type
+
+lives_ok sub {
+ $record->tuple_with_param([1,'hello', [1,2,3]]);
+} => 'Set tuple attribute without error';
+
+throws_ok sub {
+ $record->tuple_with_param([1,'hello', [qw/a b c/]]);
+}, qr/Attribute \(tuple_with_param\) does not pass the type constraint/
+ => 'Properly failed for bad value parameterized constraint';
+
+## Test tuple2 (Tuple[Int,Str,Int])
+
+ok $record->tuple2([1,'hello',3])
+ => "[1,'hello',3] properly suceeds";
+
+throws_ok sub {
+ $record->tuple2([1,2,'world']);
+}, qr/Attribute \(tuple2\) does not pass the type constraint/ => "[1,2,'world'] properly fails";
+
+throws_ok sub {
+ $record->tuple2(['hello1',2,3]);
+}, qr/Attribute \(tuple2\) does not pass the type constraint/ => "['hello',2,3] properly fails";
+
+throws_ok sub {
+ $record->tuple2(['hello2',2,'world']);
+}, qr/Attribute \(tuple2\) does not pass the type constraint/ => "['hello',2,'world'] properly fails";
+
+
+## Test tuple_with_parameterized (Tuple[Int,Str,Int,ArrayRef[Int]])
+
+ok $record->tuple_with_parameterized([1,'hello',3,[1,2,3]])
+ => "[1,'hello',3,[1,2,3]] properly suceeds";
+
+throws_ok sub {
+ $record->tuple_with_parameterized([1,2,'world']);
+}, qr/Attribute \(tuple_with_parameterized\) does not pass the type constraint/
+ => "[1,2,'world'] properly fails";
+
+throws_ok sub {
+ $record->tuple_with_parameterized(['hello1',2,3]);
+}, qr/Attribute \(tuple_with_parameterized\) does not pass the type constraint/
+ => "['hello',2,3] properly fails";
+
+throws_ok sub {
+ $record->tuple_with_parameterized(['hello2',2,'world']);
+}, qr/Attribute \(tuple_with_parameterized\) does not pass the type constraint/
+ => "['hello',2,'world'] properly fails";
+
+throws_ok sub {
+ $record->tuple_with_parameterized([1,'hello',3,[1,2,'world']]);
+}, qr/Attribute \(tuple_with_parameterized\) does not pass the type constraint/
+ => "[1,'hello',3,[1,2,'world']] properly fails";
--- /dev/null
+BEGIN {
+ use strict;
+ use warnings;
+ use Test::More tests=>17;
+ use Test::Exception;
+}
+
+{
+ package Test::MooseX::Meta::TypeConstraint::Structured::Dict;
+
+ use Moose;
+ use MooseX::Types::Structured qw(Dict Tuple);
+ use MooseX::Types::Moose qw(Int Str Object ArrayRef HashRef Maybe);
+ use MooseX::Types -declare => [qw(MyString)];
+
+ subtype MyString,
+ as 'Str',
+ where { $_=~m/abc/};
+
+ has 'dict' => (is=>'rw', isa=>Dict[name=>Str, age=>Int]);
+ has 'dict_with_maybe' => (is=>'rw', isa=>Dict[name=>Str, age=>Maybe[Int]]);
+ has 'dict_with_tuple_with_union' => (is=>'rw', isa=>Dict[key1=>Str|Object, key2=>Tuple[Int,Str|Object]] );
+}
+
+## Instantiate a new test object
+
+ok my $record = Test::MooseX::Meta::TypeConstraint::Structured::Dict->new
+ => 'Instantiated new Record test class.';
+
+isa_ok $record => 'Test::MooseX::Meta::TypeConstraint::Structured::Dict'
+ => 'Created correct object type.';
+
+# Test dict Dict[name=>Str, age=>Int]
+
+lives_ok sub {
+ $record->dict({name=>'frith', age=>23});
+} => 'Set dict attribute without error';
+
+is $record->dict->{name}, 'frith'
+ => 'correct set the dict attribute name';
+
+is $record->dict->{age}, 23
+ => 'correct set the dict attribute age';
+
+throws_ok sub {
+ $record->dict({name=>[1,2,3], age=>'sdfsdfsd'});
+}, qr/Attribute \(dict\) does not pass the type constraint/
+ => 'Got Expected Error for bad value in dict';
+
+## Test dict_with_maybe
+
+lives_ok sub {
+ $record->dict_with_maybe({name=>'frith', age=>23});
+} => 'Set dict attribute without error';
+
+is $record->dict_with_maybe->{name}, 'frith'
+ => 'correct set the dict attribute name';
+
+is $record->dict_with_maybe->{age}, 23
+ => 'correct set the dict attribute age';
+
+throws_ok sub {
+ $record->dict_with_maybe({name=>[1,2,3], age=>'sdfsdfsd'});
+}, qr/Attribute \(dict_with_maybe\) does not pass the type constraint/
+ => 'Got Expected Error for bad value in dict';
+
+throws_ok sub {
+ $record->dict_with_maybe({age=>30});
+}, qr/Attribute \(dict_with_maybe\) does not pass the type constraint/
+ => 'Got Expected Error for missing named parameter';
+
+lives_ok sub {
+ $record->dict_with_maybe({name=>'usal', age=>undef});
+} => 'Set dict attribute without error, skipping maybe';
+
+## Test dict_with_tuple_with_union: Dict[key1=>'Str|Object', key2=>Tuple['Int','Str|Object']]
+
+lives_ok sub {
+ $record->dict_with_tuple_with_union({key1=>'Hello', key2=>[1,'World']});
+} => 'Set tuple attribute without error';
+
+throws_ok sub {
+ $record->dict_with_tuple_with_union({key1=>'Hello', key2=>['World',2]});
+}, qr/Attribute \(dict_with_tuple_with_union\) does not pass the type constraint/
+ => 'Threw error on bad constraint';
+
+lives_ok sub {
+ $record->dict_with_tuple_with_union({key1=>$record, key2=>[1,'World']});
+} => 'Set tuple attribute without error';
+
+lives_ok sub {
+ $record->dict_with_tuple_with_union({key1=>'Hello', key2=>[1,$record]});
+} => 'Set tuple attribute without error';
+
+throws_ok sub {
+ $record->dict_with_tuple_with_union({key1=>1, key2=>['World',2]});
+}, qr/Attribute \(dict_with_tuple_with_union\) does not pass the type constraint/
+ => 'Threw error on bad constraint';
\ No newline at end of file
--- /dev/null
+BEGIN {
+ use strict;
+ use warnings;
+ use Test::More tests=>9;
+ use Test::Exception;
+}
+
+{
+ package Test::MooseX::Meta::TypeConstraint::Structured::Combined;
+
+ use Moose;
+ use MooseX::Types::Structured qw(Dict Tuple);
+ use MooseX::Types::Moose qw(Int Str Object ArrayRef HashRef Maybe);
+
+ has 'dict_with_tuple' => (is=>'rw', isa=>Dict[key1=>Str, key2=>Tuple[Int,Str]]);
+ has 'dict_with_tuple_with_union' => (is=>'rw', isa=>Dict[key1=>Str|Object, key2=>Tuple[Int,Str|Object]] );
+}
+
+## Instantiate a new test object
+
+ok my $record = Test::MooseX::Meta::TypeConstraint::Structured::Combined->new
+ => 'Instantiated new Record test class.';
+
+isa_ok $record => 'Test::MooseX::Meta::TypeConstraint::Structured::Combined'
+ => 'Created correct object type.';
+
+## Test dict_with_tuple
+
+lives_ok sub {
+ $record->dict_with_tuple({key1=>'Hello', key2=>[1,'World']});
+} => 'Set tuple attribute without error';
+
+throws_ok sub {
+ $record->dict_with_tuple({key1=>'Hello', key2=>['World',2]});
+}, qr/Attribute \(dict_with_tuple\) does not pass the type constraint/
+ => 'Threw error on bad constraint';
+
+## Test dict_with_tuple_with_union: Dict[key1=>'Str|Object', key2=>Tuple['Int','Str|Object']]
+
+lives_ok sub {
+ $record->dict_with_tuple_with_union({key1=>'Hello', key2=>[1,'World']});
+} => 'Set tuple attribute without error';
+
+throws_ok sub {
+ $record->dict_with_tuple_with_union({key1=>'Hello', key2=>['World',2]});
+}, qr/Attribute \(dict_with_tuple_with_union\) does not pass the type constraint/
+ => 'Threw error on bad constraint';
+
+lives_ok sub {
+ $record->dict_with_tuple_with_union({key1=>$record, key2=>[1,'World']});
+} => 'Set tuple attribute without error';
+
+lives_ok sub {
+ $record->dict_with_tuple_with_union({key1=>'Hello', key2=>[1,$record]});
+} => 'Set tuple attribute without error';
+
+throws_ok sub {
+ $record->dict_with_tuple_with_union({key1=>1, key2=>['World',2]});
+}, qr/Attribute \(dict_with_tuple_with_union\) does not pass the type constraint/
+ => 'Threw error on bad constraint';
+++ /dev/null
-BEGIN {
- use strict;
- use warnings;
- use Test::More tests=>16;
- use Test::Exception;
- use Data::Dump qw/dump/;
-
- use_ok 'Moose::Util::TypeConstraints';
-}
-
-Moose::Util::TypeConstraints::register_type_constraint(
- Moose::Meta::TypeConstraint::Parameterizable->new(
- name => 'Optional',
- package_defined_in => __PACKAGE__,
- parent => find_type_constraint('Item'),
- constraint => sub { 1 },
- constraint_generator => sub {
- my $type_parameter = shift;
- my $check = $type_parameter->_compiled_type_constraint;
- return sub {
- use Data::Dump qw/dump/;
- warn dump @_;
- return 1 if not(defined($_)) || $check->($_);
- return;
- }
- }
- )
-);
-
-ok Moose::Util::TypeConstraints::find_type_constraint('Optional')
- => 'Found the Optional Type';
-
-{
- package Test::MooseX::Types::Optional;
- use Moose;
-
- has 'Maybe_Int' => (is=>'rw', isa=>'Maybe[Int]');
- has 'Maybe_ArrayRef' => (is=>'rw', isa=>'Maybe[ArrayRef]');
- has 'Maybe_HashRef' => (is=>'rw', isa=>'Maybe[HashRef]');
- has 'Maybe_ArrayRefInt' => (is=>'rw', isa=>'Maybe[ArrayRef[Int]]');
- has 'Maybe_HashRefInt' => (is=>'rw', isa=>'Maybe[HashRef[Int]]');
-}
-
-ok my $obj = Test::MooseX::Types::Optional->new
- => 'Create good test object';
-
-## Maybe[Int]
-
-ok my $Maybe_Int = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]')
- => 'made TC Maybe[Int]';
-
-ok $Maybe_Int->check(1)
- => 'passed (1)';
-
- ok $obj->Maybe_Int(1)
- => 'assigned (1)';
-
-ok $Maybe_Int->check()
- => 'passed ()';
-
- ok $obj->Maybe_Int()
- => 'assigned ()';
-
-ok $Maybe_Int->check(0)
- => 'passed (0)';
-
- ok defined $obj->Maybe_Int(0)
- => 'assigned (0)';
-
-ok $Maybe_Int->check(undef)
- => 'passed (undef)';
-
- ok sub {$obj->Maybe_Int(undef); 1}->()
- => 'assigned (undef)';
-
-ok !$Maybe_Int->check("")
- => 'failed ("")';
-
- throws_ok sub { $obj->Maybe_Int("") },
- qr/Attribute \(Maybe_Int\) does not pass the type constraint/
- => 'failed assigned ("")';
-
-ok !$Maybe_Int->check("a")
- => 'failed ("a")';
-
- throws_ok sub { $obj->Maybe_Int("a") },
- qr/Attribute \(Maybe_Int\) does not pass the type constraint/
- => 'failed assigned ("a")';
-
-__END__
-
-
-ok $obj->Maybe_Int(undef)
- => 'passed 1';
-
-ok $obj->Maybe_Int();
-
-ok $obj->Maybe_Int('')
- => 'passed 1';
-
-ok $obj->Maybe_Int('a')
- => 'passed 1';
-
-
-
-
-ok $obj->tuple([1,'hello',3])
- => "[1,'hello',3] properly suceeds";
-
-throws_ok sub {
- $obj->tuple([1,2,'world']);
-}, qr/Validation failed for 'Int' failed with value world/ => "[1,2,'world'] properly fails";
-
-throws_ok sub {
- $obj->tuple(['hello1',2,3]);
-}, qr/Validation failed for 'Int' failed with value hello1/ => "['hello',2,3] properly fails";
-
-throws_ok sub {
- $obj->tuple(['hello2',2,'world']);
-}, qr/Validation failed for 'Int' failed with value hello2/ => "['hello',2,'world'] properly fails";
-
-
-## Test tuple_with_parameterized (Tuple[Int,Str,Int,ArrayRef[Int]])
-
-ok $obj->tuple_with_parameterized([1,'hello',3,[1,2,3]])
- => "[1,'hello',3,[1,2,3]] properly suceeds";
-
-throws_ok sub {
- $obj->tuple_with_parameterized([1,2,'world']);
-}, qr/Validation failed for 'Int' failed with value world/ => "[1,2,'world'] properly fails";
-
-throws_ok sub {
- $obj->tuple_with_parameterized(['hello1',2,3]);
-}, qr/Validation failed for 'Int' failed with value hello1/ => "['hello',2,3] properly fails";
-
-throws_ok sub {
- $obj->tuple_with_parameterized(['hello2',2,'world']);
-}, qr/Validation failed for 'Int' failed with value hello2/ => "['hello',2,'world'] properly fails";
-
-throws_ok sub {
- $obj->tuple_with_parameterized([1,'hello',3,[1,2,'world']]);
-}, qr/Validation failed for 'ArrayRef\[Int\]'/ => "[1,'hello',3,[1,2,'world']] properly fails";
-
-
-## Test tuple_with_optional (Tuple[Int,Str,Int,Optional[Int,Int]])
-
-ok $obj->tuple_with_optional([1,'hello',3])
- => "[1,'hello',3] properly suceeds";
-
-ok $obj->tuple_with_optional([1,'hello',3,1])
- => "[1,'hello',3,1] properly suceeds";
-
-ok $obj->tuple_with_optional([1,'hello',3,4])
- => "[1,'hello',3,4] properly suceeds";
-
-ok $obj->tuple_with_optional([1,'hello',3,4,5])
- => "[1,'hello',3,4,5] properly suceeds";
-
-throws_ok sub {
- $obj->tuple_with_optional([1,'hello',3,4,5,6]);
-}, qr/Too Many arguments for the available type constraints/ => "[1,'hello',3,4,5,6] properly fails";
-
-throws_ok sub {
- $obj->tuple_with_optional([1,2,'world']);
-}, qr/Validation failed for 'Int' failed with value world/ => "[1,2,'world'] properly fails";
-
-throws_ok sub {
- $obj->tuple_with_optional(['hello1',2,3]);
-}, qr/Validation failed for 'Int' failed with value hello1/ => "['hello',2,3] properly fails";
-
-throws_ok sub {
- $obj->tuple_with_optional(['hello2',2,'world']);
-}, qr/Validation failed for 'Int' failed with value hello2/ => "['hello',2,'world'] properly fails";
-
-## tuple_with_union Tuple[Int,Str,Int|Object,Optional[Int|Object,Int]]
-
-SKIP: {
-
- skip "Unions not supported for string parsed type constraints" => 8;
-
- ok $obj->tuple_with_union([1,'hello',3])
- => "[1,'hello',3] properly suceeds";
-
- ok $obj->tuple_with_union([1,'hello',3,1])
- => "[1,'hello',3,1] properly suceeds";
-
- ok $obj->tuple_with_union([1,'hello',3,4])
- => "[1,'hello',3,4] properly suceeds";
-
- ok $obj->tuple_with_union([1,'hello',3,4,5])
- => "[1,'hello',3,4,5] properly suceeds";
-
- throws_ok sub {
- $obj->tuple_with_union([1,'hello',3,4,5,6]);
- }, qr/Too Many arguments for the available type constraints/ => "[1,'hello',3,4,5,6] properly fails";
-
- throws_ok sub {
- $obj->tuple_with_union([1,2,'world']);
- }, qr/Validation failed for 'Int' failed with value world/ => "[1,2,'world'] properly fails";
-
- throws_ok sub {
- $obj->tuple_with_union(['hello1',2,3]);
- }, qr/Validation failed for 'Int' failed with value hello1/ => "['hello',2,3] properly fails";
-
- throws_ok sub {
- $obj->tuple_with_union(['hello2',2,'world']);
- }, qr/Validation failed for 'Int' failed with value hello2/ => "['hello',2,'world'] properly fails";
-}
-
+++ /dev/null
-BEGIN {
- use strict;
- use warnings;
- use Test::More tests=>3;
-}
-
-## This is a first pass at what the regex enhancements to
-## Moose::Util::TypeConstraints is going to look like. Basically I copyied
-## bits and added a little more parsing ability.
-
-{
- ## Copied from Moose::Util::TypeConstraints
- use re "eval";
-
- my $any;
- my $valid_chars = qr{[\w:]};
- my $type_atom = qr{ $valid_chars+ };
-
- 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 $op_union = qr{ \s* \| \s* }x;
- my $union = qr{ $type (?: $op_union $type )+ }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;
-
- ## Addd the | $structure_elements to this.
- $any = qr{ $type | $union | $structure_elements }x;
-
- ## New Proposed methods to parse and create
- sub _parse_structured_type_constraint {
- { no warnings 'void'; $any; } # force capture of interpolated lexical
-
- my($base, $elements) = ($_[0] =~ m{ $type_capture_parts }x);
- return ($base, [split($structure_divider, $elements)]);
- }
-
- is_deeply
- [_parse_structured_type_constraint('ArrayRef[Int,Str]')],
- ["ArrayRef", ["Int", "Str"]]
- => 'Correctly parsed ArrayRef[Int,Str]';
-
- is_deeply
- [_parse_structured_type_constraint('ArrayRef[ArrayRef[Int],Str]')],
- ["ArrayRef", ["ArrayRef[Int]", "Str"]]
- => 'Correctly parsed ArrayRef[ArrayRef[Int],Str]';
-
- is_deeply
- [_parse_structured_type_constraint('HashRef[key1 => Int, key2=>Int, key3=>ArrayRef[Int]]')],
- ["HashRef", ["key1", "Int", "key2", "Int", "key3", "ArrayRef[Int]"]]
- => 'Correctly parsed HashRef[key1 => Int, key2=>Int, key3=>ArrayRef[Int]]';
-
-}
-
\ No newline at end of file
projects / gitmo/MooseX-Types-Structured.git / commitdiff