use Moose;
use Moose::Util::TypeConstraints ();
+use Scalar::Util qw(blessed);
+
extends 'Moose::Meta::TypeConstraint';
=head1 NAME
has 'parent_type_constraint' => (
is=>'ro',
isa=>'Object',
- predicate=>'has_parent_type_constraint',
default=> sub {
Moose::Util::TypeConstraints::find_type_constraint("Any");
},
has 'constraining_value_type_constraint' => (
is=>'ro',
isa=>'Object',
- predicate=>'has_constraining_value_type_constraint',
default=> sub {
Moose::Util::TypeConstraints::find_type_constraint("Any");
},
required=>1,
);
-=head2 constrainting_value
+=head2 constraining_value
This is the actual value that constraints the L</parent_type_constraint>
=cut
has 'constraining_value' => (
- reader=>'constraining_value',
- writer=>'_set_constraining_value',
+ is=>'ro',
predicate=>'has_constraining_value',
);
};
}
-=head2 parameterize ($dependent, $callback, $constraining)
+=head2 parameterize (@args)
Given a ref of type constraints, create a structured type.
-
+
=cut
sub parameterize {
- my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
-
- die 'something';
-
+ my $self = shift @_;
my $class = ref $self;
- my $name = $self->_generate_subtype_name($dependent_tc, $callback, $constraining_tc);
- my $constraint_generator = $self->__infer_constraint_generator;
-
- return $class->new(
- name => $name,
- parent => $self,
- dependent_type_constraint=>$dependent_tc,
- comparison_callback=>$callback,
- constraint_generator => $constraint_generator,
- constraining_type_constraint => $constraining_tc,
- );
+
+ 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,
+ );
+
+ } 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(@_) {
+ if($#_) {
+ if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) {
+ $args = {@_};
+ } else {
+ $args = [@_];
+ }
+ } else {
+ $args = $_[0];
+ }
+
+ } else {
+ ## TODO: Is there a use case for parameterizing null or undef?
+ Moose->throw_error('Cannot Parameterize null values.');
+ }
+
+ if(my $err = $self->constraining_value_type_constraint->validate($args)) {
+ Moose->throw_error($err);
+ } else {
+ ## TODO memorize or do a registry lookup on the name as an optimization
+ return $class->new(
+ name => $self->name."[$args]",
+ parent => $self,
+ constraint => $self->constraint,
+ constraining_value => $args,
+ parent_type_constraint=>$self->parent_type_constraint,
+ constraining_value_type_constraint => $self->constraining_value_type_constraint,
+ );
+ }
+ }
}
=head2 _generate_subtype_name
sub _generate_subtype_name {
my ($self, $parent_tc, $constraining_tc) = @_;
return sprintf(
- "%s_depends_on_%s",
+ $self."[%s, %s]",
$parent_tc, $constraining_tc,
);
}
-=head2 __infer_constraint_generator
-
-This returns a CODEREF which generates a suitable constraint generator. Not
-user servicable, you'll never call this directly.
+=head2 create_child_type
- TBD, this is definitely going to need some work. Cargo culted from some
- code I saw in Moose::Meta::TypeConstraint::Parameterized or similar. I
- Don't think I need this, since Dependent types require parameters, so
- will always have a constrain generator.
+modifier to make sure we get the constraint_generator
=cut
-sub __infer_constraint_generator {
- my ($self) = @_;
- if($self->has_constraint_generator) {
- return $self->constraint_generator;
- } else {
- warn "I'm doing the questionable infer generator thing";
- return sub {
- ## I'm not sure about this stuff but everything seems to work
- my $tc = shift @_;
- my $merged_tc = [
- @$tc,
- ];
-
- $self->constraint->($merged_tc, @_);
- };
- }
-}
-
-=head2 compile_type_constraint
+around 'create_child_type' => sub {
+ my ($create_child_type, $self, %opts) = @_;
+ return $self->$create_child_type(
+ %opts,
+ parent=> $self,
+ parent_type_constraint=>$self->parent_type_constraint,
+ constraining_value_type_constraint => $self->constraining_value_type_constraint,
+ );
+};
-hook into compile_type_constraint so we can set the correct validation rules.
+=head2 equals ($type_constraint)
+Override the base class behavior so that a dependent type equal both the parent
+type and the overall dependent container. This behavior may change if we can
+figure out what a dependent type is (multiply inheritance or a role...)
+=cut
-around 'compile_type_constraint' => sub {
- my ($compile_type_constraint, $self) = @_;
+around 'equals' => sub {
+ my ( $equals, $self, $type_or_name ) = @_;
- if($self->has_comparison_callback &&
- $self->has_constraining_type_constraint) {
- my $generated_constraint = $self->generate_constraint_for(
- $self->comparison_callback,
- );
- $self->_set_constraint($generated_constraint);
+ my $other = defined $type_or_name ?
+ Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
+ Moose->throw_error("Can't call $self ->equals without a parameter");
+
+ Moose->throw_error("$type_or_name is not a registered Type")
+ unless $other;
+
+ if(my $parent = $other->parent) {
+ return $self->$equals($other)
+ || $self->parent->equals($parent);
+ } else {
+ return $self->$equals($other);
}
-
- return $self->$compile_type_constraint;
};
-=head2 create_child_type
-
-modifier to make sure we get the constraint_generator
+around 'is_subtype_of' => sub {
+ my ( $is_subtype_of, $self, $type_or_name ) = @_;
-=cut
+ my $other = defined $type_or_name ?
+ Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
+ Moose->throw_error("Can't call $self ->equals without a parameter");
+
+ Moose->throw_error("$type_or_name is not a registered Type")
+ unless $other;
+
+ return $self->$is_subtype_of($other)
+ || $self->parent_type_constraint->is_subtype_of($other);
-around 'create_child_type' => sub {
- my ($create_child_type, $self, %opts) = @_;
- return $self->$create_child_type(
- %opts,
- #constraint_generator => $self->__infer_constraint_generator,
- );
};
-=head2 equals
-
-Override the base class behavior.
+sub is_a_type_of {
+ my ($self, @args) = @_;
+ return ($self->equals(@args) ||
+ $self->is_subtype_of(@args));
+}
-sub equals {
- my ( $self, $type_or_name ) = @_;
- my $other = Moose::Util::TypeConstraints::find_type_constraint("$type_or_name");
+around 'check' => sub {
+ my ($check, $self, @args) = @_;
+ if($self->has_constraining_value) {
+ push @args, $self->constraining_value;
+ }
+ return $self->parent_type_constraint->check(@args) && $self->$check(@args)
+};
- return (
- $other->isa(__PACKAGE__)
- and
- $self->dependent_type_constraint->equals($other)
- and
- $self->constraining_type_constraint->equals($other)
- and
- $self->parent->equals($other->parent)
- );
-}
+around 'validate' => sub {
+ my ($validate, $self, @args) = @_;
+ if($self->has_constraining_value) {
+ push @args, $self->constraining_value;
+ }
+ return $self->parent_type_constraint->validate(@args) || $self->$validate(@args);
+};
=head2 get_message
return $self->$get_message($value);
};
-=head2 _throw_error ($error)
-
-Given a string, delegate to the Moose exception object
-
-=cut
-
-sub _throw_error {
- my $self = shift @_;
- my $err = defined $_[0] ? $_[0] : 'Exception Thrown without Message';
- require Moose; Moose->throw_error($err);
-}
-
=head1 SEE ALSO
The following modules or resources may be of interest.
-use Test::More tests=>5; {
+use Test::More tests=>53; {
use strict;
use warnings;
use MooseX::Dependent::Types qw(Dependent);
- use MooseX::Types -declare=>[qw(SubDependent)];
+ use MooseX::Types::Moose qw(Int Any);
+ use MooseX::Types -declare=>[qw(SubDependent IntLessThan EvenInt)];
use Moose::Util::TypeConstraints;
-
- ok subtype( SubDependent, as Dependent ),
- 'Create a useless subtype';
+
ok Dependent->check(1),
- 'Dependent is basically an Any';
- ok SubDependent->check(1),
- 'SubDependent is basically an Any';
+ 'Dependent is basically an "Any"';
+
+ ok !Dependent->validate(1),
+ 'No Error Message';
+
is Dependent->parent, 'Any',
'Dependent is an Any';
+
+ is Dependent->name, 'MooseX::Dependent::Types::Dependent',
+ 'Dependent has expected name';
+
+ is Dependent->get_message,
+ "Validation failed for 'MooseX::Dependent::Types::Dependent' failed with value undef",
+ 'Got Expected Message';
+
+ ok Dependent->equals(Dependent),
+ 'Dependent equal Dependent';
+
+ ok Dependent->is_a_type_of(Dependent),
+ 'Dependent is_a_type_of Dependent';
+
+ ok Dependent->is_a_type_of('Any'),
+ 'Dependent is_a_type_of Any';
+
+ ok Dependent->is_subtype_of('Any'),
+ 'Dependent is_subtype_of Dependent';
+
+ is Dependent->parent_type_constraint, 'Any',
+ 'Correct parent type';
+
+ is subtype( SubDependent, as Dependent ),
+ 'main::SubDependent',
+ 'Create a useless subtype';
+
+ ok SubDependent->check(1),
+ 'SubDependent is basically an "Any"';
+
+ ok !SubDependent->validate(1),
+ 'validate returned no error message';
+
is SubDependent->parent, 'MooseX::Dependent::Types::Dependent',
'SubDependent is a Dependent';
- is Dependent->get_message, "Validation failed for 'MooseX::Dependent::Types::Dependent' failed with value undef",
- 'Got Expected Message'
- warn SubDependent->get_message;
-}
+
+ is SubDependent->name, 'main::SubDependent',
+ 'Dependent has expected name';
+
+ is SubDependent->get_message,
+ "Validation failed for 'main::SubDependent' failed with value undef",
+ 'Got Expected Message';
+
+ ok SubDependent->equals(SubDependent),
+ 'SubDependent equal SubDependent';
+
+ ok !SubDependent->equals(Dependent),
+ 'SubDependent does not equal Dependent';
+
+ ok SubDependent->is_a_type_of(Dependent),
+ 'SubDependent is_a_type_of Dependent';
+
+ ok SubDependent->is_a_type_of(Any),
+ 'SubDependent is_a_type_of Any';
+
+ ok SubDependent->is_subtype_of('Any'),
+ 'SubDependent is_subtype_of Dependent';
+
+ ok !SubDependent->is_subtype_of(SubDependent),
+ 'SubDependent is not is_subtype_of SubDependent';
+
+ ok subtype( EvenInt,
+ as Int,
+ where {
+ my $val = shift @_;
+ return $val % 2 ? 0:1;
+ }),
+ 'Created a subtype of Int';
-__END__
+ ok !EvenInt->check('aaa'), '"aaa" not an Int';
+ ok !EvenInt->check(1), '1 is not even';
+ ok EvenInt->check(2), 'but 2 is!';
+
+ ok subtype( IntLessThan,
+ as Dependent[EvenInt, Int],
+ where {
+ my $value = shift @_;
+ my $constraining = shift @_ || 200;
+ return ($value < $constraining && $value > 5);
+ }),
+ 'Created IntLessThan subtype';
+
+ ok !IntLessThan->check('aaa'),
+ '"aaa" is not an integer';
+
+ is IntLessThan->validate('aaa'),
+ "Validation failed for 'main::EvenInt' failed with value aaa",
+ 'Got expected error messge for "aaa"';
+
+ ok !IntLessThan->check(1),
+ '1 smaller than 5';
-check
-validate
-get_message
-name
-equals
-is_a_type_of
-is_subtype_of
\ No newline at end of file
+ ok !IntLessThan->check(2),
+ '2 smaller than 5';
+
+ ok !IntLessThan->check(15),
+ '15 greater than 5 (but odd)';
+
+ ok !IntLessThan->check(301),
+ '301 is too big';
+
+ ok !IntLessThan->check(400),
+ '400 is too big';
+
+ ok IntLessThan->check(10),
+ '10 greater than 5 (and even)';
+
+ is IntLessThan->validate(1),
+ "Validation failed for 'main::EvenInt' failed with value 1",
+ 'error message is correct';
+
+ is IntLessThan->name, 'main::IntLessThan',
+ 'Got correct name for IntLessThan';
+
+ is IntLessThan->parent, 'MooseX::Dependent::Types::Dependent[main::EvenInt, Int]',
+ 'IntLessThan is a Dependent';
+
+ is IntLessThan->parent_type_constraint, EvenInt,
+ 'Parent is an Int';
+
+ is IntLessThan->constraining_value_type_constraint, Int,
+ 'constraining is an Int';
+
+ ok IntLessThan->equals(IntLessThan),
+ 'IntLessThan equals IntLessThan';
+
+ ok IntLessThan->is_subtype_of(Dependent),
+ 'IntLessThan is_subtype_of Dependent';
+
+ ok IntLessThan->is_subtype_of(Int),
+ 'IntLessThan is_subtype_of Int';
+
+ ok IntLessThan->is_a_type_of(Dependent),
+ 'IntLessThan is_a_type_of Dependent';
+
+ ok IntLessThan->is_a_type_of(Int),
+ 'IntLessThan is_a_type_of Int';
+
+ ok IntLessThan->is_a_type_of(IntLessThan),
+ 'IntLessThan is_a_type_of IntLessThan';
+
+ ok( (my $lessThan100GreatThen5andEvenInt = IntLessThan[100]),
+ 'Parameterized!');
+
+ ok !$lessThan100GreatThen5andEvenInt->check(150),
+ '150 Not less than 100';
+
+ ok !$lessThan100GreatThen5andEvenInt->check(151),
+ '151 Not less than 100';
+
+ ok !$lessThan100GreatThen5andEvenInt->check(2),
+ 'Not greater than 5';
+
+ ok !$lessThan100GreatThen5andEvenInt->check(51),
+ 'Not even';
+
+ ok !$lessThan100GreatThen5andEvenInt->check('aaa'),
+ 'Not Int';
+
+ ok $lessThan100GreatThen5andEvenInt->check(42),
+ 'is Int, is even, greater than 5, less than 100';
+
+ #die IntLessThan->validate(100);
+ #use Data::Dump qw/dump/;
+ #warn dump IntLessThan;
+}
projects / gitmo/MooseX-Dependent.git / commitdiff