use Moose;
use Moose::Util::TypeConstraints ();
use Scalar::Util qw(blessed);
-
+use Data::Dump;
+use Digest::MD5;
+
extends 'Moose::Meta::TypeConstraint';
=head1 NAME
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 @_;
+
+ my $name = $self->_generate_subtype_name($arg1, $arg2);
+ if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
+ return $exists;
+ } else {
+ my $type_constraint = $class->new(
+ name => $name,
+ parent => $self,
+ constraint => $self->constraint,
+ parent_type_constraint=>$arg1,
+ constraining_value_type_constraint => $arg2,
+ );
+ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
+ return $type_constraint;
+ }
+ } 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);
+
+ my $name = $self->_generate_subtype_name($self->parent_type_constraint, $arg1);
+ if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
+ return $exists;
+ } else {
+ my $type_constraint = $class->new(
+ name => $name,
+ parent => $self,
+ constraint => $self->constraint,
+ parent_type_constraint=>$self->parent_type_constraint,
+ constraining_value_type_constraint => $arg1,
+ );
+ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
+ return $type_constraint;
+ }
+ }
} 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(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 $sig = $args;
+ if(ref $sig) {
+ $sig = Digest::MD5::md5_hex(Data::Dump::dump($args));
+ }
+ my $name = $self->name."[$sig]";
+ if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
+ return $exists;
+ } else {
+ my $type_constraint = $class->new(
+ name => $name,
+ parent => $self,
+ constraint => $self->constraint,
+ constraining_value => $args,
+ parent_type_constraint=>$self->parent_type_constraint,
+ constraining_value_type_constraint => $self->constraining_value_type_constraint,
+ );
+ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
+ return $type_constraint;
+ }
}
}
}
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);
};
};
+around 'coerce' => sub {
+ my ($coerce, $self, @args) = @_;
+ if($self->coercion) {
+ if(my $value = $self->$coerce(@args)) {
+ return $value;
+ }
+ }
+ return $self->parent->coerce(@args);
+};
+
=head2 get_message
Give you a better peek into what's causing the error.
projects / gitmo/MooseX-Dependent.git / blobdiff