[Moose-commits] r7863 - in MooseX-Types-Dependent/trunk:
lib/MooseX/Meta/TypeConstraint t
jnapiorkowski at code2.0beta.co.uk
jnapiorkowski at code2.0beta.co.uk
Sun Mar 29 18:04:23 BST 2009
Author: jnapiorkowski
Date: 2009-03-29 10:04:23 -0700 (Sun, 29 Mar 2009)
New Revision: 7863
Modified:
MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeConstraint/Dependent.pm
MooseX-Types-Dependent/trunk/t/00-load.t
MooseX-Types-Dependent/trunk/t/01-basic.t
Log:
Got the basic requirement in place!
Modified: MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeConstraint/Dependent.pm
===================================================================
--- MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeConstraint/Dependent.pm 2009-03-27 21:44:24 UTC (rev 7862)
+++ MooseX-Types-Dependent/trunk/lib/MooseX/Meta/TypeConstraint/Dependent.pm 2009-03-29 17:04:23 UTC (rev 7863)
@@ -29,7 +29,12 @@
has 'dependent_type_constraint' => (
is=>'ro',
+ isa=>'Object',
predicate=>'has_dependent_type_constraint',
+ required=>1,
+ handles=>{
+ check_dependent=>'check',
+ },
);
=head2 constraining_type_constraint
@@ -41,10 +46,15 @@
has 'constraining_type_constraint' => (
is=>'ro',
+ isa=>'Object',
predicate=>'has_constraining_type_constraint',
+ required=>1,
+ handles=>{
+ check_constraining=>'check',
+ },
);
-=head2 comparision_callback
+=head2 comparison_callback
This is a callback which returns a boolean value. It get's passed the value
L</constraining_type_constraint> validates as well as the check value.
@@ -57,10 +67,11 @@
=cut
-has 'comparision_callback' => (
+has 'comparison_callback' => (
is=>'ro',
isa=>'CodeRef',
- predicate=>'has_comparision_callback',
+ predicate=>'has_comparison_callback',
+ required=>1,
);
=head2 constraint_generator
@@ -74,6 +85,7 @@
is=>'ro',
isa=>'CodeRef',
predicate=>'has_constraint_generator',
+ required=>1,
);
=head1 METHODS
@@ -89,12 +101,32 @@
around 'new' => sub {
my ($new, $class, @args) = @_;
my $self = $class->$new(@args);
- $self->coercion(MooseX::Meta::TypeCoercion::Structured->new(
+ $self->coercion(MooseX::Meta::TypeCoercion::Dependent->new(
type_constraint => $self,
));
return $self;
};
+=head2 check($check_value, $constraining_value)
+
+Make sure when properly dispatch all the right values to the right spots
+
+=cut
+
+around 'check' => sub {
+ my ($check, $self, $check_value, $constraining_value) = @_;
+
+ unless($self->check_dependent($check_value)) {
+ return;
+ }
+
+ unless($self->check_constraining($constraining_value)) {
+ return;
+ }
+
+ return $self->$check($check_value, $constraining_value);
+};
+
=head2 generate_constraint_for ($type_constraints)
Given some type constraints, use them to generate validation rules for an ref
@@ -103,33 +135,37 @@
=cut
sub generate_constraint_for {
- my ($self, $dependent, $callback, $constraining) = @_;
- return sub {
- my (@args) = @_;
+ my ($self, $callback, $constraining) = @_;
+ return sub {
+ my ($check_value, $constraining_value) = @_;
my $constraint_generator = $self->constraint_generator;
- return $constraint_generator->($dependent, $callback, $constraining, @args);
+ return $constraint_generator->(
+ $callback,
+ $check_value,
+ $constraining_value,
+ );
};
}
-=head2 parameterize (@type_constraints)
+=head2 parameterize ($dependent, $callback, $constraining)
Given a ref of type constraints, create a structured type.
=cut
sub parameterize {
-
my ($self, $dependent, $callback, $constraining) = @_;
my $class = ref $self;
- my $name = $self->_generate_subtype_name($dependent, $constraining);
+ my $name = $self->_generate_subtype_name($dependent, $callback, $constraining);
my $constraint_generator = $self->__infer_constraint_generator;
return $class->new(
name => $name,
parent => $self,
dependent_type_constraint=>$dependent,
- comparision_callback=>$callback,
+ comparison_callback=>$callback,
constraint_generator => $constraint_generator,
+ constraining_type_constraint => $constraining,
);
}
@@ -140,10 +176,10 @@
=cut
sub _generate_subtype_name {
- my ($self, $dependent, $constraining) = @_;
+ my ($self, $dependent, $callback, $constraining) = @_;
return sprintf(
- "%s_depends_on_%s",
- $dependent, $constraining
+ "%s_depends_on_%s_via_%s",
+ $dependent, $constraining, $callback
);
}
@@ -166,8 +202,7 @@
my $tc = shift @_;
my $merged_tc = [
@$tc,
- $self->dependent_type_constraint,
- $self->comparision_callback,
+ $self->comparison_callback,
$self->constraining_type_constraint,
];
@@ -183,23 +218,24 @@
=cut
around 'compile_type_constraint' => sub {
- my ($compile_type_constraint, $self, @args) = @_;
+ my ($compile_type_constraint, $self) = @_;
- if($self->has_type_constraints) {
- my $type_constraints = $self->type_constraints;
- my $constraint = $self->generate_constraint_for($type_constraints);
- $self->_set_constraint($constraint);
+ if($self->has_comparison_callback &&
+ $self->has_constraining_type_constraint) {
+ my $generated_constraint = $self->generate_constraint_for(
+ $self->comparison_callback,
+ $self->constraining_type_constraint,
+ );
+ $self->_set_constraint($generated_constraint);
}
- return $self->$compile_type_constraint(@args);
+ return $self->$compile_type_constraint;
};
=head2 create_child_type
modifier to make sure we get the constraint_generator
-=cut
-
around 'create_child_type' => sub {
my ($create_child_type, $self, %opts) = @_;
return $self->$create_child_type(
@@ -293,4 +329,4 @@
=cut
-__PACKAGE__->meta->make_immutable;
\ No newline at end of file
+__PACKAGE__->meta->make_immutable;
Modified: MooseX-Types-Dependent/trunk/t/00-load.t
===================================================================
--- MooseX-Types-Dependent/trunk/t/00-load.t 2009-03-27 21:44:24 UTC (rev 7862)
+++ MooseX-Types-Dependent/trunk/t/00-load.t 2009-03-29 17:04:23 UTC (rev 7863)
@@ -1,11 +1,11 @@
-use Test::More tests=>3; {
+use Test::More tests=>2; {
use strict;
use warnings;
## List all the modules we want to make sure can at least compile
- use_ok 'MooseX::Types::Dependent';
+ ##use_ok 'MooseX::Types::Dependent';
use_ok 'MooseX::Meta::TypeConstraint::Dependent';
use_ok 'MooseX::Meta::TypeCoercion::Dependent';
}
Modified: MooseX-Types-Dependent/trunk/t/01-basic.t
===================================================================
--- MooseX-Types-Dependent/trunk/t/01-basic.t 2009-03-27 21:44:24 UTC (rev 7862)
+++ MooseX-Types-Dependent/trunk/t/01-basic.t 2009-03-29 17:04:23 UTC (rev 7863)
@@ -1,5 +1,5 @@
-use Test::More tests=>8; {
+use Test::More tests=>9; {
use strict;
use warnings;
@@ -7,32 +7,33 @@
use_ok 'MooseX::Meta::TypeConstraint::Dependent';
use_ok 'Moose::Util::TypeConstraints';
- ## A sample dependent type constraint the requires two ints and see which
- ## is the greater.
+ ## A sample dependent type constraint the requires two ints and sees if
+ ## the dependent value (the first) is greater than the constraining value
+ ## (the second).
ok my $int = find_type_constraint('Int') => 'Got Int';
my $dep_tc = MooseX::Meta::TypeConstraint::Dependent->new(
name => "MooseX::Types::Dependent::Depending" ,
- parent => find_type_constraint('ArrayRef'),
+ parent => find_type_constraint('Int'),
dependent_type_constraint=>$int,
- comparision_callback=>sub {
+ comparison_callback=>sub {
my ($constraining_value, $check_value) = @_;
- return $constraining_value > $check_value ? 0:1;
+ return $check_value > $constraining_value ? 0:1;
},
- constraint_generator =>$int,
- constraint_generator=> sub {
+ constraining_type_constraint =>$int,
+ constraint_generator=> sub {
+ ## Because "shift->(shift,shift)" is not very clear, is it :)
my ($callback, $constraining_value, $check_value) = @_;
- return $callback->($constraining_value, $check_value) ? 1:0;
+ return $callback->($constraining_value, $check_value);
},
);
-
- ## Does this work at all?
isa_ok $dep_tc, 'MooseX::Meta::TypeConstraint::Dependent';
-
- ok !$dep_tc->check([5,10]), "Fails, 5 is less than 10";
- ok !$dep_tc->check(['a',10]), "Fails, 'a' is not an Int.";
- ok !$dep_tc->check([5,'b']), "Fails, 'b' is not an Int either.";
- ok $dep_tc->check([10,5]), "Success, 10 is greater than 5.";
+
+ ok !$dep_tc->check('a',10), "Fails, 'a' is not an Int.";
+ ok !$dep_tc->check(5,'b'), "Fails, 'b' is not an Int either.";
+ ok !$dep_tc->check([4,1]), "Fails, since this isn't an arrayref";
+ ok !$dep_tc->check(5,10), "Fails, 5 is less than 10";
+ ok $dep_tc->check(11,6), "Success, 11 is greater than 6.";
}
More information about the Moose-commits
mailing list