package ## Hide from PAUSE
- MooseX::Meta::TypeConstraint::Dependent;
+ MooseX::Dependent::Meta::TypeConstraint::Dependent;
use Moose;
use Moose::Util::TypeConstraints ();
-use MooseX::Meta::TypeCoercion::Dependent;
-use Devel::PartialDump;
+use Scalar::Util qw(blessed);
+
extends 'Moose::Meta::TypeConstraint';
=head1 NAME
-MooseX::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints.
+MooseX::Dependent::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints.
=head1 DESCRIPTION
-see L<MooseX::Types::Dependent> for examples and details of how to use dependent
+see L<MooseX::Dependent> for examples and details of how to use dependent
types. This class is a subclass of L<Moose::Meta::TypeConstraint> which
provides the gut functionality to enable dependent type constraints.
This class defines the following attributes.
-=head2 dependent_type_constraint
+=head2 parent_type_constraint
-The type constraint whose validity is being made dependent on a value that is a
-L</constraining_type_constraint>
+The type constraint whose validity is being made dependent.
=cut
-has 'dependent_type_constraint' => (
+has 'parent_type_constraint' => (
is=>'ro',
isa=>'Object',
- predicate=>'has_dependent_type_constraint',
- handles=>{
- check_dependent=>'check',
- get_message_dependent=>'get_message',
+ default=> sub {
+ Moose::Util::TypeConstraints::find_type_constraint("Any");
},
+ required=>1,
);
-=head2 constraining_type_constraint
+
+=head2 constraining_value_type_constraint
This is a type constraint which defines what kind of value is allowed to be the
-constraining value of the depending type.
+constraining value of the dependent type.
=cut
-has 'constraining_type_constraint' => (
+has 'constraining_value_type_constraint' => (
is=>'ro',
isa=>'Object',
- predicate=>'has_constraining_type_constraint',
- handles=>{
- check_constraining=>'check',
- get_message_constraining=>'get_message',
+ default=> sub {
+ Moose::Util::TypeConstraints::find_type_constraint("Any");
},
+ required=>1,
);
-=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.
-
-This callback is executed in addition to anything you put into a 'where' clause.
-However, the 'where' clause only get's the check value.
-
-Exercise some sanity, this should be limited to actual comparision operations,
-not as a sneaky way to mess with the constraining value.
-
-This should return a Bool, suitable for ->check (That is true for valid, false
-for fail).
-
-=cut
-
-has 'comparison_callback' => (
- is=>'ro',
- isa=>'CodeRef',
- predicate=>'has_comparison_callback',
-);
-
-=head2 constraint_generator
+=head2 constraining_value
-A subref or closure that contains the way we validate incoming values against
-a set of type constraints.
+This is the actual value that constraints the L</parent_type_constraint>
=cut
-has 'constraint_generator' => (
+has 'constraining_value' => (
is=>'ro',
- isa=>'CodeRef',
- predicate=>'has_constraint_generator',
- required=>1,
+ predicate=>'has_constraining_value',
);
=head1 METHODS
This class defines the following methods.
-=head2 new
-
-Initialization stuff.
-
-=cut
-
-around 'new' => sub {
- my ($new, $class, @args) = @_;
- my $self = $class->$new(@args);
- $self->coercion(MooseX::Meta::TypeCoercion::Dependent->new(
- type_constraint => $self,
- ));
- return $self;
-};
-
-=head2 validate
-
-We intercept validate in order to custom process the message.
+=head2 parameterize (@args)
+Given a ref of type constraints, create a structured type.
+
=cut
-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);
+sub parameterize {
+ my $self = shift @_;
+ my $class = ref $self;
- 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");
+ 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 @_;
+
+ 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 {
- return $self->get_message($args);
+ 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,
+ );
}
- }
-};
-
-=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
+ } else {
+ 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];
+ }
-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;
+ } else {
+ ## TODO: Is there a use case for parameterizing null or undef?
+ Moose->throw_error('Cannot Parameterize null values.');
}
-
- unless($self->check_constraining($constraining)) {
- $_[0]->{message} = $self->get_message_constraining($constraining)
- if $_[0];
- return;
+
+ 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,
+ );
}
-
- my $constraint_generator = $self->constraint_generator;
- return $constraint_generator->(
- $dependent,
- $callback,
- $constraining,
- );
- };
-}
-
-=head2 parameterize ($dependent, $callback, $constraining)
-
-Given a ref of type constraints, create a structured type.
-
-=cut
-
-sub parameterize {
- my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
- 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,
- );
+ }
}
=head2 _generate_subtype_name
=cut
sub _generate_subtype_name {
- my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
+ my ($self, $parent_tc, $constraining_tc) = @_;
return sprintf(
- "%s_depends_on_%s_via_%s",
- $dependent_tc, $constraining_tc, $callback,
+ $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->comparison_callback,
- $self->constraining_type_constraint,
- ];
-
- $self->constraint->($merged_tc, @_);
- };
- }
-}
+around 'create_child_type' => sub {
+ my ($create_child_type, $self, %opts) = @_;
+ if($self->has_constraining_value) {
+ $opts{constraining_value} = $self->constraining_value;
+ }
+ return $self->$create_child_type(
+ %opts,
+ parent=> $self,
+ parent_type_constraint=>$self->parent_type_constraint,
+ constraining_value_type_constraint => $self->constraining_value_type_constraint,
+ );
+};
-=head2 compile_type_constraint
+=head2 equals ($type_constraint)
-hook into compile_type_constraint so we can set the correct validation rules.
+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.
-
-=cut
+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) = @_;
+ return (
+ $self->parent_type_constraint->check(@args) &&
+ $self->$check(@args)
+ );
+};
+around 'validate' => sub {
+ my ($validate, $self, @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)
+ $self->parent_type_constraint->validate(@args) ||
+ $self->$validate(@args)
);
-}
+};
+
+around '_compiled_type_constraint' => sub {
+ my ($method, $self, @args) = @_;
+ my $coderef = $self->$method(@args);
+ my $constraining;
+ if($self->has_constraining_value) {
+ $constraining = $self->constraining_value;
+ }
+
+ return sub {
+ my @local_args = @_;
+ if(my $err = $self->constraining_value_type_constraint->validate($constraining)) {
+ Moose->throw_error($err);
+ }
+ $coderef->(@local_args, $constraining);
+ };
+};
=head2 get_message
Give you a better peek into what's causing the error.
-=cut
-
around 'get_message' => sub {
my ($get_message, $self, $value) = @_;
return $self->$get_message($value);
=cut
-__PACKAGE__->meta->make_immutable;
+__PACKAGE__->meta->make_immutable(inline_constructor => 0);
+
projects / gitmo/MooseX-Dependent.git / blobdiff