return @parents;
}
+sub create_childtype {
+ my ($self, %opts) = @_;
+ my $class = ref $self;
+ return $class->new(%opts, parent => $self);
+}
+
## this should get deprecated actually ...
sub union { Carp::croak "DEPRECATED" }
=item B<has_hand_optimized_type_constraint>
+=item B<create_childtype>
+
=back
=head2 DEPRECATED METHOD
. $self->parent->name . " doesn't subtype or coerce from a parameterizable type.");
}
+sub create_childtype {
+ my ($self, %opts) = @_;
+
+ return Moose::Meta::TypeConstraint->new(%opts, parent => $self);
+
+ return $self->SUPER::create_subtype(
+ %opts,
+ type_parameter=>$self->type_parameter,
+ );
+}
+
1;
__END__
=item B<equals>
+=item B<create_childtype>
+
=back
=head1 BUGS
return 0;
}
+sub create_childtype {
+ my ($self, %opts) = @_;
+ my $class = ref $self;
+ my $constraint = Moose::Meta::TypeConstraint->new(%opts, parent => $self);
+
+ # if we have a type constraint union, and no
+ # type check, this means we are just aliasing
+ # the union constraint, which means we need to
+ # handle this differently.
+ # - SL
+ if (
+ not(defined $opts{constraint})
+ && $self->has_coercion
+ ) {
+ $constraint->coercion(Moose::Meta::TypeCoercion::Union->new(
+ type_constraint => $self,
+ ));
+ }
+
+ return $constraint;
+}
+
1;
__END__
=item B<has_hand_optimized_type_constraint>
+=item B<create_childtype>
+
=back
=head1 BUGS
. $pkg_defined_in )
if defined $type;
}
-
- my $class = "Moose::Meta::TypeConstraint";
-
- # FIXME should probably not be a special case
- if ( defined $parent and $parent = find_or_parse_type_constraint($parent) ) {
- $class = "Moose::Meta::TypeConstraint::Parameterizable"
- if $parent->isa("Moose::Meta::TypeConstraint::Parameterizable");
- }
-
- my $constraint = $class->new(
- name => $name || '__ANON__',
+
+ ## Here are the basic options we will use to create the constraint. These
+ ## may be altered depending on the parent type, etc.
+
+ my %opts = (
+ name => $name || '__ANON__',
package_defined_in => $pkg_defined_in,
- ($parent ? (parent => $parent ) : ()),
($check ? (constraint => $check) : ()),
($message ? (message => $message) : ()),
($optimized ? (optimized => $optimized) : ()),
);
-
- # NOTE:
- # if we have a type constraint union, and no
- # type check, this means we are just aliasing
- # the union constraint, which means we need to
- # handle this differently.
- # - SL
- if (not(defined $check)
- && $parent->isa('Moose::Meta::TypeConstraint::Union')
- && $parent->has_coercion
- ){
- $constraint->coercion(Moose::Meta::TypeCoercion::Union->new(
- type_constraint => $parent
- ));
+
+ ## If we have a parent we make sure to instantiate this new type constraint
+ ## as a subclass of the parents meta class. We need to see if the $parent
+ ## is already a blessed TC or if we need to go make it based on it's name
+
+ my $constraint;
+
+ if(
+ defined $parent
+ and $parent = blessed $parent ? $parent:find_or_parse_type_constraint($parent)
+ ) {
+ ## creating the child is a job we delegate to the parent, since each
+ ## parent may have local customization needs to influence it's child.
+ $constraint = $parent->create_childtype(%opts);
+ } else {
+ ## If for some reason the above couldn't create a type constraint, let's
+ ## make sure to create something.
+ $constraint = Moose::Meta::TypeConstraint->new(%opts);
}
+ ## Unless we have a request to make an anonynmous constraint, let's add it
+ ## to the $REGISTRY so that it gets cached for quicker lookups next time
+
$REGISTRY->add_type_constraint($constraint)
if defined $name;
is($p->name, 'HashRef[Int]', '... parent name is correct');
- ok($t->check({ one => 1, two => 2 }), '... validated it correctly');
+ ok($t->check({ one => 1, two => 2 }), '... validated {one=>1, two=>2} correctly');
ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly');
ok( $t->equals($t), "equals to self" );
is($p->name, 'HashRef[Int]', '... parent name is correct');
ok($t->check({ one => 1, two => 2 }), '... validated it correctly');
- ok(!$t->check({ zero => 10, one => 11, two => 12 }), '... validated it correctly');
+ ok(!$t->check({ zero => 10, one => 11, two => 12 }), '... validated { zero => 10, one => 11, two => 12 } correctly');
ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly');
}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 16;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose::Util::TypeConstraints');
+ use_ok('Moose::Meta::TypeConstraint');
+}
+
+## Create a subclass with a custom method
+
+{
+ package Test::Moose::Meta::TypeConstraint::AnySubType;
+ use Moose;
+ extends 'Moose::Meta::TypeConstraint';
+
+ sub my_custom_method {
+ return 1;
+ }
+}
+
+my $Int = Moose::Util::TypeConstraints::find_type_constraint('Int');
+ok $Int, 'Got a good type contstraint';
+
+my $parent = Test::Moose::Meta::TypeConstraint::AnySubType->new({
+ name => "Test::Moose::Meta::TypeConstraint::AnySubType" ,
+ parent => $Int,
+});
+
+ok $parent, 'Created type constraint';
+ok $parent->check(1), 'Correctly passed';
+ok ! $parent->check('a'), 'correctly failed';
+ok $parent->my_custom_method, 'found the custom method';
+
+my $subtype1 = Moose::Util::TypeConstraints::subtype 'another_subtype',
+ as $parent;
+
+ok $subtype1, 'Created type constraint';
+ok $subtype1->check(1), 'Correctly passed';
+ok ! $subtype1->check('a'), 'correctly failed';
+ok $subtype1->my_custom_method, 'found the custom method';
+
+
+my $subtype2 = Moose::Util::TypeConstraints::subtype 'another_subtype',
+ as $subtype1,
+ where { $_ < 10 };
+
+ok $subtype2, 'Created type constraint';
+ok $subtype2->check(1), 'Correctly passed';
+ok ! $subtype2->check('a'), 'correctly failed';
+ok ! $subtype2->check(100), 'correctly failed';
+
+ok $subtype2->my_custom_method, 'found the custom method';
\ No newline at end of file
projects / gitmo/Moose.git / commitdiff