use Moose;
use Moose::Util::TypeConstraints ();
+use MooseX::Dependent::Meta::TypeCoercion::Dependent;
use Scalar::Util qw(blessed);
-
+use Data::Dump;
+use Digest::MD5;
+
extends 'Moose::Meta::TypeConstraint';
=head1 NAME
types. This class is a subclass of L<Moose::Meta::TypeConstraint> which
provides the gut functionality to enable dependent type constraints.
+This class is not intended for public consumption. Please don't subclass it
+or rely on it. Chances are high stuff here is going to change a lot. For
+example, I will probably refactor this into several classes to get rid of all
+the ugly conditionals.
+
=head1 ATTRIBUTES
This class defines the following attributes.
This class defines the following methods.
+=head2 BUILD
+
+Do some post build stuff
+
+=cut
+
+## Right now I add in the dependent type coercion until I can merge some Moose
+## changes upstream
+
+around 'new' => sub {
+ my ($new, $class, @args) = @_;
+ my $self = $class->$new(@args);
+ my $coercion = MooseX::Dependent::Meta::TypeCoercion::Dependent->new(type_constraint => $self);
+ $self->coercion($coercion);
+ return $self;
+};
+
=head2 parameterize (@args)
Given a ref of type constraints, create a structured type.
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,
- );
+ 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);
- 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,
- );
+ 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 {
my $args;
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,
+ );
+
+ ## TODO This is probably going to have to go away (too many things added to the registry)
+ ##Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
+ return $type_constraint;
+ }
}
}
}
}
};
+=head2 is_subtype_of
+
+Method modifier to make sure we match on subtype for both the dependent type
+as well as the type being made dependent
+
+=cut
+
around 'is_subtype_of' => sub {
my ( $is_subtype_of, $self, $type_or_name ) = @_;
};
-sub is_a_type_of {
- my ($self, @args) = @_;
- return ($self->equals(@args) ||
- $self->is_subtype_of(@args));
-}
+=head2 check
+
+As with 'is_subtype_of', we need to dual dispatch the method request
+
+=cut
around 'check' => sub {
my ($check, $self, @args) = @_;
);
};
+=head2 validate
+
+As with 'is_subtype_of', we need to dual dispatch the method request
+
+=cut
+
around 'validate' => sub {
my ($validate, $self, @args) = @_;
return (
);
};
+=head2 _compiled_type_constraint
+
+modify this method so that we pass along the constraining value to the constraint
+coderef and also throw the correct error message if the constraining value does
+not match it's requirement.
+
+=cut
+
around '_compiled_type_constraint' => sub {
my ($method, $self, @args) = @_;
my $coderef = $self->$method(@args);
};
};
+=head2 coerce
+
+More method modification to support dispatch coerce to a parent.
+
+=cut
+
+around 'coerce' => sub {
+ my ($coerce, $self, @args) = @_;
+
+ if($self->has_constraining_value) {
+ push @args, $self->constraining_value;
+ if(@{$self->coercion->type_coercion_map}) {
+ my $coercion = $self->coercion;
+ my $coerced = $self->$coerce(@args);
+ if(defined $coerced) {
+ return $coerced;
+ } else {
+ my $parent = $self->parent;
+ return $parent->coerce(@args);
+ }
+ } else {
+ my $parent = $self->parent;
+ return $parent->coerce(@args);
+ }
+ }
+ else {
+ return $self->$coerce(@args);
+ }
+ return;
+};
+
=head2 get_message
Give you a better peek into what's causing the error.
=cut
-__PACKAGE__->meta->make_immutable(inline_constructor => 0);
+1;
+##__PACKAGE__->meta->make_immutable(inline_constructor => 0);
projects / gitmo/MooseX-Dependent.git / blobdiff