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',
},
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
+
+We intercept validate in order to custom process the message
-Make sure when properly dispatch all the right values to the right spots
=cut
around 'check' => sub {
my ($check, $self, @args) = @_;
- return $self->$check(@args);
+ my ($result, $message) = $self->_compiled_type_constraint->(@args);
+ warn $result;
+ return $result;
+};
+
+around 'validate' => sub {
+ my ($validate, $self, @args) = @_;
+ my ($result, $message) = $self->_compiled_type_constraint->(@args);
+
+ if($result) {
+ return $result;
+ } else {
+ if(defined $message) {
+ return "Inner: $message";
+ } else { warn '......................';
+ return $self->get_message(@args);
+ }
+ }
};
=head2 generate_constraint_for ($type_constraints)
=cut
sub generate_constraint_for {
- my ($self, $callback, $constraining) = @_;
+ my ($self, $callback) = @_;
return sub {
- my ($dependent_pair) = @_;
- my ($check_value, $constraining_value) = @$dependent_pair;
+ my $dependent_pair = shift @_;
+ my ($dependent, $constraining) = @$dependent_pair;
## First need to test the bits
- unless($self->check_dependent($check_value)) {
- return;
+ unless($self->check_dependent($dependent)) {
+ return (undef, 'bbbbbb');
}
- unless($self->check_constraining($constraining_value)) {
+ unless($self->check_constraining($constraining)) {
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,
);
}
if($self->has_constraint_generator) {
return $self->constraint_generator;
} else {
+ warn "I'm doing the questioning 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);
}
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(