use Moose;
use Moose::Util::TypeConstraints ();
use MooseX::Meta::TypeCoercion::Dependent;
+use Devel::PartialDump;
extends 'Moose::Meta::TypeConstraint';
=head1 NAME
is=>'ro',
isa=>'Object',
predicate=>'has_dependent_type_constraint',
- required=>1,
handles=>{
- check_dependent=>'check',
+ check_dependent=>'check',
+ get_message_dependent=>'get_message',
},
);
is=>'ro',
isa=>'Object',
predicate=>'has_constraining_type_constraint',
- required=>1,
handles=>{
- check_constraining=>'check',
+ check_constraining=>'check',
+ get_message_constraining=>'get_message',
},
);
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',
- required=>1,
);
=head2 constraint_generator
return $self;
};
-=head2 check($check_value, $constraining_value)
+=head2 validate
-Make sure when properly dispatch all the right values to the right spots
+We intercept validate in order to custom process the message.
=cut
-around 'check' => sub {
- my ($check, $self, $check_value, $constraining_value) = @_;
-
- unless($self->check_dependent($check_value)) {
- return;
- }
+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);
- unless($self->check_constraining($constraining_value)) {
- return;
+ 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);
+ }
}
-
- return $self->$check($check_value, $constraining_value);
};
=head2 generate_constraint_for ($type_constraints)
=cut
sub generate_constraint_for {
- my ($self, $callback, $constraining) = @_;
+ my ($self, $callback) = @_;
return sub {
- my ($check_value, $constraining_value) = @_;
+ 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,
- $check_value,
- $constraining_value,
+ $constraining,
);
};
}
=cut
sub parameterize {
- my ($self, $dependent, $callback, $constraining) = @_;
+ my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
my $class = ref $self;
- my $name = $self->_generate_subtype_name($dependent, $callback, $constraining);
+ 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,
+ dependent_type_constraint=>$dependent_tc,
comparison_callback=>$callback,
constraint_generator => $constraint_generator,
- constraining_type_constraint => $constraining,
+ constraining_type_constraint => $constraining_tc,
);
}
=cut
sub _generate_subtype_name {
- my ($self, $dependent, $callback, $constraining) = @_;
+ my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
return sprintf(
"%s_depends_on_%s_via_%s",
- $dependent, $constraining, $callback
+ $dependent_tc, $constraining_tc, $callback,
);
}
This returns a CODEREF which generates a suitable constraint generator. Not
user servicable, you'll never call this directly.
- TBD, this is definitely going to need some work.
+ 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.
=cut
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 @_;
$self->has_constraining_type_constraint) {
my $generated_constraint = $self->generate_constraint_for(
$self->comparison_callback,
- $self->constraining_type_constraint,
);
- $self->_set_constraint($generated_constraint);
+ $self->_set_constraint($generated_constraint);
}
return $self->$compile_type_constraint;
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(
);
};
-=head2 is_a_type_of
-
-=head2 is_subtype_of
-
=head2 equals
Override the base class behavior.
- TBD
+=cut
sub equals {
my ( $self, $type_or_name ) = @_;
- my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+ my $other = Moose::Util::TypeConstraints::find_type_constraint("$type_or_name");
- return unless $other->isa(__PACKAGE__);
-
return (
- $self->type_constraints_equals($other)
+ $other->isa(__PACKAGE__)
and
- $self->parent->equals( $other->parent )
+ $self->dependent_type_constraint->equals($other)
+ and
+ $self->constraining_type_constraint->equals($other)
+ and
+ $self->parent->equals($other->parent)
);
}
-=head2 type_constraints_equals
-
-Checks to see if the internal type contraints are equal.
-
- TBD
-
-sub type_constraints_equals {
- my ($self, $other) = @_;
- my @self_type_constraints = @{$self->type_constraints||[]};
- my @other_type_constraints = @{$other->type_constraints||[]};
-
- ## Incoming ay be either arrayref or hashref, need top compare both
- while(@self_type_constraints) {
- my $self_type_constraint = shift @self_type_constraints;
- my $other_type_constraint = shift @other_type_constraints
- || return; ## $other needs the same number of children.
-
- if( ref $self_type_constraint) {
- $self_type_constraint->equals($other_type_constraint)
- || return; ## type constraints obviously need top be equal
- } else {
- $self_type_constraint eq $other_type_constraint
- || return; ## strings should be equal
- }
-
- }
-
- return 1; ##If we get this far, everything is good.
-}
-
=head2 get_message
-Give you a better peek into what's causing the error. For now we stringify the
-incoming deep value with L<Devel::PartialDump> and pass that on to either your
-custom error message or the default one. In the future we'll try to provide a
-more complete stack trace of the actual offending elements
+Give you a better peek into what's causing the error.
- TBD
+=cut
around 'get_message' => sub {
my ($get_message, $self, $value) = @_;
- my $new_value = Devel::PartialDump::dump($value);
- return $self->$get_message($new_value);
+ return $self->$get_message($value);
};
=head1 SEE ALSO
projects / gitmo/MooseX-Dependent.git / blobdiff