constraint 'UniqueID'. This $set_obj become part of the constraint (you can't
actually use the constraint without it.)
- UniqueID[$set_obj]->check(1); ## Not OK, since one isn't unique in $set_obj
- UniqueID[$set_obj]->check(100); ## OK, since 100 isn't in the set.
+ UniqueID([$set_obj])->check(1); ## Not OK, since one isn't unique in $set_obj
+ UniqueID([$set_obj])->check('AAA'); ## Not OK, since AAA is not an Int
+ UniqueID([$set_obj])->check(100); ## OK, since 100 isn't in the set.
You can assign the result of a parameterized dependent type to a variable or to
another type constraint, as like any other type constraint:
required=>1,
);
+
=head2 constraining_value_type_constraint
This is a type constraint which defines what kind of value is allowed to be the
predicate=>'has_constraining_value',
);
-=head2 constraint_generator
-
-A subref or closure that contains the way we validate incoming values against
-a set of type constraints.
-
-
-has 'constraint_generator' => (
- is=>'ro',
- isa=>'CodeRef',
- predicate=>'has_constraint_generator',
- required=>1,
-);
-
=head1 METHODS
This class defines the following methods.
-=head2 validate
-
-We intercept validate in order to custom process the message.
-
-override 'validate' => sub {
- my ($self, @args) = @_;
- my $compiled_type_constraint = $self->_compiled_type_constraint;
- my $message = bless {message=>undef}, 'MooseX::Types::Dependent::Message';
- my $result = $compiled_type_constraint->(@args, $message);
-
- if($result) {
- return $result;
- } else {
- my $args = Devel::PartialDump::dump(@args);
- if(my $message = $message->{message}) {
- return $self->get_message("$args, Internal Validation Error is: $message");
- } else {
- return $self->get_message($args);
- }
- }
-};
-
-=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)
-
-
-sub generate_constraint_for {
- my ($self, $callback) = @_;
- return sub {
- my $dependent_pair = shift @_;
- my ($dependent, $constraining) = @$dependent_pair;
-
- ## First need to test the bits
- unless($self->check_dependent($dependent)) {
- $_[0]->{message} = $self->get_message_dependent($dependent)
- if $_[0];
- return;
- }
-
- unless($self->check_constraining($constraining)) {
- $_[0]->{message} = $self->get_message_constraining($constraining)
- if $_[0];
- return;
- }
-
- my $constraint_generator = $self->constraint_generator;
- return $constraint_generator->(
- $dependent,
- $callback,
- $constraining,
- );
- };
-}
-
=head2 parameterize (@args)
Given a ref of type constraints, create a structured type.
sub parameterize {
my $self = shift @_;
my $class = ref $self;
-
+
+ Moose->throw_error("$self already has a constraining value.") if
+ $self->has_constraining_value;
+
if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
my $arg1 = shift @_;
- my $arg2 = shift @_ || $self->constraining_value_type_constraint;
-
- Moose->throw_error("$arg2 is not a type constraint")
- unless $arg2->isa('Moose::Meta::TypeConstraint');
- Moose->throw_error('Too Many Args! Two are allowed.') if @_;
-
- return $class->new(
- name => $self->_generate_subtype_name($arg1, $arg2),
- parent => $self,
- constraint => $self->constraint,
- parent_type_constraint=>$arg1,
- constraining_value_type_constraint => $arg2,
- );
-
+ if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
+ my $arg2 = shift @_ || $self->constraining_value_type_constraint;
+
+ ## TODO fix this crap!
+ Moose->throw_error("$arg2 is not a type constraint")
+ unless $arg2->isa('Moose::Meta::TypeConstraint');
+
+ Moose->throw_error("$arg1 is not a type of: ".$self->parent_type_constraint->name)
+ unless $arg1->is_a_type_of($self->parent_type_constraint);
+
+ Moose->throw_error("$arg2 is not a type of: ".$self->constraining_value_type_constraint->name)
+ unless $arg2->is_a_type_of($self->constraining_value_type_constraint);
+
+ Moose->throw_error('Too Many Args! Two are allowed.') if @_;
+
+ return $class->new(
+ name => $self->_generate_subtype_name($arg1, $arg2),
+ parent => $self,
+ constraint => $self->constraint,
+ parent_type_constraint=>$arg1,
+ constraining_value_type_constraint => $arg2,
+ );
+ } else {
+ Moose->throw_error("$arg1 is not a type of: ".$self->constraining_value_type_constraint->name)
+ unless $arg1->is_a_type_of($self->constraining_value_type_constraint);
+
+ return $class->new(
+ name => $self->_generate_subtype_name($self->parent_type_constraint, $arg1),
+ parent => $self,
+ constraint => $self->constraint,
+ parent_type_constraint=>$self->parent_type_constraint,
+ constraining_value_type_constraint => $arg1,
+ );
+ }
} else {
- Moose->throw_error("$self already has a constraining value.") if
- $self->has_constraining_value;
-
my $args;
## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}]
if(@_) {
around 'check' => sub {
my ($check, $self, @args) = @_;
- return $self->parent_type_constraint->check(@args) && $self->$check(@args)
+ return (
+ $self->parent_type_constraint->check(@args) &&
+ $self->$check(@args)
+ );
};
around 'validate' => sub {
my ($validate, $self, @args) = @_;
- return $self->parent_type_constraint->validate(@args) || $self->$validate(@args);
+ return (
+ $self->parent_type_constraint->validate(@args) ||
+ $self->$validate(@args)
+ );
};
around '_compiled_type_constraint' => sub {
my ($method, $self, @args) = @_;
my $coderef = $self->$method(@args);
- my @extra_args = $self->has_constraining_value ? $self->constraining_value : ();
+ my $constraining;
+ if($self->has_constraining_value) {
+ $constraining = $self->constraining_value;
+ }
+
return sub {
my @local_args = @_;
- $coderef->(@local_args, @extra_args);
+ if(my $err = $self->constraining_value_type_constraint->validate($constraining)) {
+ Moose->throw_error($err);
+ }
+ $coderef->(@local_args, $constraining);
};
};
my ($int, $set) = @_;
return $set->find($int) ? 0:1;
};
-
+
=head1 DESCRIPTION
A L<MooseX::Types> library for creating dependent types. A dependent type
where {
my ($value, $range) = @_;
return ($value >= $range->{min} &&
- $value =< $range->{max});
+ $value <= $range->{max});
};
- RangedInt[{min=>10,max=>100}]->check(50); ## OK
- RangedInt[{min=>50, max=>75}]->check(99); ## Not OK, 99 exceeds max
- RangedInt[{min=>99, max=>10}]->check(10); ## Not OK, not a valid Range!
+ RangedInt([{min=>10,max=>100}])->check(50); ## OK
+ RangedInt([{min=>50, max=>75}])->check(99); ## Not OK, 99 exceeds max
+
+This throws a hard Moose exception. You'll need to capture it in an eval or
+related exception catching system (see L<Try::Catch>).
+
+ RangedInt([{min=>99, max=>10}])->check(10); ## Not OK, not a valid Range!
+
+If you can't accept a hard exception here, you'll need to test the constraining
+values first, as in:
+
+ my $range = {min=>99, max=>10};
+ if(my $err = Range->validate($range)) {
+ ## Handle #$err
+ } else {
+ RangedInt($range)->check(99);
+ }
Please note that for ArrayRef or HashRef dependent type constraints, as in the
example above, as a convenience we automatically ref the incoming type
parameters, so that the above could also be written as:
- RangedInt[min=>10,max=>100]->check(50); ## OK
- RangedInt[min=>50, max=>75]->check(99); ## Not OK, 99 exceeds max
- RangedInt[min=>99, max=>10]->check(10); ## Not OK, not a valid Range!
+ RangedInt([min=>10,max=>100])->check(50); ## OK
+ RangedInt([min=>50, max=>75])->check(99); ## Not OK, 99 exceeds max
+ RangedInt([min=>99, max=>10])->check(10); ## Exception, not a valid Range!
This is the preferred syntax, as it improve readability and adds to the
conciseness of your type constraint declarations. An exception wil be thrown if
your type parameters don't match the required reference type.
+Also not that if you 'chain' parameterization results with a method call like:
+
+ TypeConstraint([$ob])->method;
+
+You need to have the "(...)" around the ArrayRef in the Type Constraint
+parameters. This seems to have something to do with the precendent level of
+"->". Patches or thoughts welcomed. You only need to do this in the above
+case which I imagine is not a very common case.
+
==head2 Subtyping a Dependent type constraints
When subclassing a dependent type you must be careful to match either the
subtype PositiveInt,
as Int,
where {
- shift >= 0;
+ my ($value, $range) = @_;
+ return $value >= 0;
};
## subtype Range to re-parameterize Range with subtypes
as RangedInt[PositiveRange];
Notice how re-parameterizing the dependent type 'RangedInt' works slightly
-differently from re-parameterizing 'PositiveRange'? Although it initially takes
+differently from re-parameterizing 'PositiveRange' Although it initially takes
two type constraint values to declare a dependent type, should you wish to
later re-parameterize it, you only use a subtype of the second type parameter
(the dependent type constraint) since the first type constraint sets the parent
Which should work like:
- OlderThanAge[{older_than=>25}]->check(39); ## is OK
- OlderThanAge[older_than=>1]->check(9); ## OK, using reference type inference
+ OlderThanAge([{older_than=>25}])->check(39); ## is OK
+ OlderThanAge([older_than=>1])->check(9); ## OK, using reference type inference
And you can create coercions like:
=cut
1;
-
-__END__
-
-oose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
- Moose::Meta::TypeConstraint::Parameterizable->new(
- name => 'MooseX::Dependent::Types::Dependent',
- parent => find_type_constraint('Any'),
- constraint => sub { 0 },
- constraint_generator=> sub {
- my ($dependent_val, $callback, $constraining_val) = @_;
- return $callback->($dependent_val, $constraining_val);
- },
- )
-);
-
-
-
-$REGISTRY->add_type_constraint(
- Moose::Meta::TypeConstraint::Parameterizable->new(
- name => 'HashRef',
- package_defined_in => __PACKAGE__,
- parent => find_type_constraint('Ref'),
- constraint => sub { ref($_) eq 'HASH' },
- optimized =>
- \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
- constraint_generator => sub {
- my $type_parameter = shift;
- my $check = $type_parameter->_compiled_type_constraint;
- return sub {
- foreach my $x ( values %$_ ) {
- ( $check->($x) ) || return;
- }
- 1;
- }
- }
- )
-);
\ No newline at end of file
-use Test::More tests=>62; {
+use Test::More tests=>79; {
use strict;
use warnings;
use MooseX::Dependent::Types qw(Dependent);
- use MooseX::Types::Moose qw(Int Any);
- use MooseX::Types -declare=>[qw(SubDependent IntLessThan EvenInt
- LessThan100GreatThen5andEvenIntNot44)];
+ use MooseX::Types::Moose qw(Int Any Maybe);
use Moose::Util::TypeConstraints;
+ use MooseX::Types -declare=>[qw(SubDependent IntLessThan EvenInt
+ LessThan100GreatThen5andEvenIntNot44 IntNot54
+ GreatThen5andEvenIntNot54or64)];
+
ok Dependent->check(1),
'Dependent is basically an "Any"';
ok EvenInt->check(2), 'but 2 is!';
ok subtype( IntLessThan,
- as Dependent[EvenInt, Int],
+ as Dependent[EvenInt, Maybe[Int]],
where {
my $value = shift @_;
- my $constraining = shift @_ || 200; #warn "..... $constraining ......";
+ my $constraining = shift @_ || 200;
return ($value < $constraining && $value > 5);
}),
'Created IntLessThan subtype';
is IntLessThan->name, 'main::IntLessThan',
'Got correct name for IntLessThan';
- is IntLessThan->parent, 'MooseX::Dependent::Types::Dependent[main::EvenInt, Int]',
+ is IntLessThan->parent, 'MooseX::Dependent::Types::Dependent[main::EvenInt, Maybe[Int]]',
'IntLessThan is a Dependent';
is IntLessThan->parent_type_constraint, EvenInt,
'Parent is an Int';
- is IntLessThan->constraining_value_type_constraint, Int,
+ is IntLessThan->constraining_value_type_constraint, (Maybe[Int]),
'constraining is an Int';
ok IntLessThan->equals(IntLessThan),
as IntLessThan[100],
where {
my $value = shift @_;
- return $value == 44 ? 0:1;
+ return $value != 44;
}),
'Created LessThan100GreatThen5andEvenIntNot44 subtype';
ok !LessThan100GreatThen5andEvenIntNot44->check(44),
'is Int, is even, greater than 5, less than 100 BUT 44!';
+ ok subtype( IntNot54,
+ as Maybe[Int],
+ where {
+ my $val = shift @_ || 200;
+ return $val != 54
+ }),
+ 'Created a subtype of Int';
+
+ ok IntNot54->check(100), 'Not 54';
+ ok !IntNot54->check(54), '54!!';
+
+ ok( subtype( GreatThen5andEvenIntNot54or64,
+ as IntLessThan[IntNot54],
+ where {
+ my $value = shift @_;
+ return $value != 64;
+ }),
+ 'Created GreatThen5andEvenIntNot54or64 subtype');
+
+ is( (GreatThen5andEvenIntNot54or64->name),
+ 'main::GreatThen5andEvenIntNot54or64',
+ 'got expected name');
+
+ ok GreatThen5andEvenIntNot54or64->check(150),
+ '150 is even, less than 200, not 54 or 64 but > 5';
+
+ ok !GreatThen5andEvenIntNot54or64->check(202),
+ '202 is even, exceeds 200, not 54 or 64 but > 5';
+
+ is( ((GreatThen5andEvenIntNot54or64[100])->name),
+ 'main::GreatThen5andEvenIntNot54or64[100]',
+ 'got expected name');
+
+ ok !GreatThen5andEvenIntNot54or64([100])->check(150),
+ '150 Not less than 100';
+
+ ok !GreatThen5andEvenIntNot54or64([100])->check(300),
+ '300 Not less than 100 (check to make sure we are not defaulting 200)';
+
+ ok !GreatThen5andEvenIntNot54or64([100])->check(151),
+ '151 Not less than 100';
+
+ ok !GreatThen5andEvenIntNot54or64([100])->check(2),
+ 'Not greater than 5';
+
+ ok !GreatThen5andEvenIntNot54or64([100])->check(51),
+ 'Not even';
+
+ ok !GreatThen5andEvenIntNot54or64([100])->check('aaa'),
+ 'Not Int';
+
+ ok GreatThen5andEvenIntNot54or64([100])->check(42),
+ 'is Int, is even, greater than 5, less than 100';
+
+ ok !GreatThen5andEvenIntNot54or64([100])->check(64),
+ 'is Int, is even, greater than 5, less than 100 BUT 64!';
+
+ CHECKPARAM: {
+ eval { GreatThen5andEvenIntNot54or64([54])->check(32) };
+ like $@,
+ qr/Validation failed for 'main::IntNot54' failed with value 54/,
+ 'Got Expected Error';
+ }
+
#die IntLessThan->validate(100);
#use Data::Dump qw/dump/;
#warn dump IntLessThan;
projects / gitmo/MooseX-Dependent.git / commitdiff