=cut
-has 'constraint_generator' => (is=>'ro', isa=>'CodeRef');
+has 'constraint_generator' => (
+ is=>'ro',
+ isa=>'CodeRef',
+ predicate=>'has_constraint_generator',
+);
=head1 METHODS
sub generate_constraint_for {
my ($self, $type_constraints) = @_;
return sub {
+ my (@args) = @_;
my $constraint_generator = $self->constraint_generator;
- return $constraint_generator->($type_constraints, @_);
+ return $constraint_generator->($type_constraints, @args);
};
}
=cut
sub parameterize {
+
my ($self, @type_constraints) = @_;
my $class = ref $self;
my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']';
+ my $constraint_generator = $self->__infer_constraint_generator;
return $class->new(
name => $name,
parent => $self,
type_constraints => \@type_constraints,
- constraint_generator => $self->constraint_generator || sub {
+ constraint_generator => $constraint_generator,
+ );
+}
+
+=head2 __infer_constraint_generator
+
+This returns a CODEREF which generates a suitable constraint generator. Not
+user servicable, you'll never call this directly.
+
+=cut
+
+sub __infer_constraint_generator {
+ my ($self) = @_;
+ if($self->has_constraint_generator) {
+ return $self->constraint_generator;
+ } else {
+ return sub {
+ ## I'm not sure about this stuff but everything seems to work
my $tc = shift @_;
my $merged_tc = [@$tc, @{$self->parent->type_constraints}];
- $self->constraint->($merged_tc, @_);
- },
- );
+ $self->constraint->($merged_tc, @_);
+ };
+ }
}
=head2 compile_type_constraint
use Moose;
use Moose::Util::TypeConstraints;
use MooseX::Meta::TypeConstraint::Structured;
-use MooseX::Types -declare => [qw(Dict Tuple)];
+use MooseX::Types -declare => [qw(Dict Tuple Optional)];
our $VERSION = '0.05';
our $AUTHORITY = 'cpan:JJNAPIORK';
MooseX::Meta::TypeConstraint::Structured->new(
name => "MooseX::Types::Structured::Tuple" ,
parent => find_type_constraint('ArrayRef'),
- constraint_generator=> sub {
+ constraint_generator=> sub {
## Get the constraints and values to check
- my @type_constraints = @{shift @_};
- my @values = @{shift @_};
+ my ($type_constraints, $values) = @_;
+ my @type_constraints = defined $type_constraints ? @$type_constraints: ();
+ my @values = defined $values ? @$values: ();
## Perform the checking
while(@type_constraints) {
my $type_constraint = shift @type_constraints;
MooseX::Meta::TypeConstraint::Structured->new(
name => "MooseX::Types::Structured::Dict",
parent => find_type_constraint('HashRef'),
- constraint_generator=> sub {
+ constraint_generator=> sub {
## Get the constraints and values to check
- my %type_constraints = @{shift @_};
- my %values = %{shift @_};
+ my ($type_constraints, $values) = @_;
+ my %type_constraints = defined $type_constraints ? @$type_constraints: ();
+ my %values = defined $values ? %$values: ();
## Perform the checking
while(%type_constraints) {
my($key, $type_constraint) = each %type_constraints;
unless($type_constraint->check($value)) {
return;
}
- } else {
+ } else {
return;
}
}
## Make sure there are no leftovers.
- if(%values) {
+ if(%values) {
return;
} elsif(%type_constraints) {
return;
)
);
+OPTIONAL: {
+ my $Optional = Moose::Meta::TypeConstraint::Parameterizable->new(
+ name => 'MooseX::Types::Structured::Optional',
+ package_defined_in => __PACKAGE__,
+ parent => find_type_constraint('Item'),
+ constraint => sub { 1 },
+ constraint_generator => sub {
+ my ($type_parameter, @args) = @_;
+ my $check = $type_parameter->_compiled_type_constraint();
+ return sub {
+ my (@args) = @_;
+ if(exists($args[0])) {
+ ## If it exists, we need to validate it
+ $check->($args[0]);
+ } else {
+ ## But it's is okay if the value doesn't exists
+ return 1;
+ }
+ }
+ }
+ );
+
+ Moose::Util::TypeConstraints::register_type_constraint($Optional);
+ Moose::Util::TypeConstraints::add_parameterizable_type($Optional);
+}
+
+
=head1 SEE ALSO
The following modules or resources may be of interest.
BEGIN {
use strict;
use warnings;
- use Test::More tests=>56;
+ use Test::More tests=>68;
}
+use Moose::Util::TypeConstraints;
use MooseX::Types::Structured qw(Dict Tuple);
use MooseX::Types::Moose qw(Int Str Object ArrayRef HashRef);
use MooseX::Types -declare => [qw(
ok (!MyTuple1->is_subtype_of(MyTuple3), 'MyTuple1 NOT is_subtype_of MyTuple3');
ok (!MyTuple2->is_subtype_of(MyTuple3), 'MyTuple2 NOT is_subtype_of MyTuple3');
+## Test manual parameterizing
+
+PARAMETERIZE: {
+
+ ok (my $int = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Int'), 'Got Int');
+ ok (my $str = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Str'), 'Got Str');
+ ok (my $hashref = Moose::Util::TypeConstraints::find_or_parse_type_constraint('HashRef[Int]'), 'Got HashRef');
+
+ ## Test Dict->parameterize
+ ok (my $test_dict = Dict(), 'Created Test Dict');
+ ok (my $person = $test_dict->parameterize(name=>$str, age=>$int), 'Parameterized It');
+ ok ($person->check({name=>'John', age=>21}), 'Passed');
+ ok ($person->check({age=>25, name=>'User'}), 'Passed');
+
+ ## Test Tuple->parameterize
+ ok (my $test_tuple = Tuple(), 'Created Test Tuple');
+ ok (my $int_and_hashref = $test_tuple->parameterize($int, $hashref), 'Parameterized It');
+ ok ($int_and_hashref->check([1, {key=>2, key2=>3}]), "Passed");
+ ok (!$int_and_hashref->check(['a', {key=>2, key2=>3}]), "Not Passed");
+ ok (!$int_and_hashref->check([1, {key=>'a', key2=>3}]), "Not Passed");
+}
use strict;
use warnings;
-use Test::More tests=>15;
+use Test::More tests=>26;
use Moose::Util::TypeConstraints;
-use Moose::Meta::TypeConstraint::Parameterizable;
-
-use Data::Dump qw/dump/;
-
-## Sketch for how this could work
-
-ok my $Optional = 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, @args) = @_;
- my $check = $type_parameter->_compiled_type_constraint();
- return sub {
- my (@args) = @_;
- if(exists($args[0])) {
- ## If it exists, we need to validate it
- $check->($args[0]);
- } else {
- ## But it's is okay if the value doesn't exists
- return 1;
- }
- }
- }
-);
-
-Moose::Util::TypeConstraints::register_type_constraint($Optional);
-Moose::Util::TypeConstraints::add_parameterizable_type($Optional);
-## END SKETCH
-
-isa_ok $Optional, 'Moose::Meta::TypeConstraint::Parameterizable';
+use MooseX::Types::Structured qw(Optional);
+
+## Setup Stuff
+ok my $Optional = Moose::Util::TypeConstraints::find_or_parse_type_constraint('MooseX::Types::Structured::Optional')
+ => 'Got Optional';
+
+isa_ok $Optional
+ => 'Moose::Meta::TypeConstraint::Parameterizable';
ok my $int = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Int')
=> 'Got Int';
ok my $arrayref = Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Int]')
=> 'Got ArrayRef[Int]';
-ok my $Optional_Int = $Optional->parameterize($int), 'Parameterized Int';
-ok my $Optional_ArrayRef = $Optional->parameterize($arrayref), 'Parameterized ArrayRef';
-
-ok $Optional_Int->check() => 'Optional is allowed to not exist';
-
-ok !$Optional_Int->check(undef) => 'Optional is NOT allowed to be undef';
-ok $Optional_Int->check(199) => 'Correctly validates 199';
-ok !$Optional_Int->check("a") => 'Correctly fails "a"';
+BASIC: {
+ ok my $Optional_Int = $Optional->parameterize($int), 'Parameterized Int';
+ ok my $Optional_ArrayRef = $Optional->parameterize($arrayref), 'Parameterized ArrayRef';
+
+ ok $Optional_Int->check() => 'Optional is allowed to not exist';
+
+ ok !$Optional_Int->check(undef) => 'Optional is NOT allowed to be undef';
+ ok $Optional_Int->check(199) => 'Correctly validates 199';
+ ok !$Optional_Int->check("a") => 'Correctly fails "a"';
+
+ ok $Optional_ArrayRef->check() => 'Optional is allowed to not exist';
+ ok !$Optional_ArrayRef->check(undef) => 'Optional is NOT allowed to be undef';
+ ok $Optional_ArrayRef->check([1,2,3]) => 'Correctly validates [1,2,3]';
+ ok !$Optional_ArrayRef->check("a") => 'Correctly fails "a"';
+ ok !$Optional_ArrayRef->check(["a","b"]) => 'Correctly fails ["a","b"]';
+}
+
+SUBREF: {
+ ok my $Optional_Int = Optional->parameterize($int),'Parameterized Int';
+ ok my $Optional_ArrayRef = Optional->parameterize($arrayref), 'Parameterized ArrayRef';
+
+ ok $Optional_Int->check() => 'Optional is allowed to not exist';
+
+ ok !$Optional_Int->check(undef) => 'Optional is NOT allowed to be undef';
+ ok $Optional_Int->check(199) => 'Correctly validates 199';
+ ok !$Optional_Int->check("a") => 'Correctly fails "a"';
+
+ ok $Optional_ArrayRef->check() => 'Optional is allowed to not exist';
+ ok !$Optional_ArrayRef->check(undef) => 'Optional is NOT allowed to be undef';
+ ok $Optional_ArrayRef->check([1,2,3]) => 'Correctly validates [1,2,3]';
+ ok !$Optional_ArrayRef->check("a") => 'Correctly fails "a"';
+ ok !$Optional_ArrayRef->check(["a","b"]) => 'Correctly fails ["a","b"]';
+}
+
+## Test via the subref Optional()
-ok $Optional_ArrayRef->check() => 'Optional is allowed to not exist';
-ok !$Optional_ArrayRef->check(undef) => 'Optional is NOT allowed to be undef';
-ok $Optional_ArrayRef->check([1,2,3]) => 'Correctly validates [1,2,3]';
-ok !$Optional_ArrayRef->check("a") => 'Correctly fails "a"';
-ok !$Optional_ArrayRef->check(["a","b"]) => 'Correctly fails ["a","b"]';
\ No newline at end of file
projects / gitmo/MooseX-Types-Structured.git / commitdiff