[Moose-commits] r7705 - in
Moose/branches/typeconstraint_intersection: lib
lib/Moose/Meta/TypeCoercion lib/Moose/Meta/TypeConstraint
lib/Moose/Util t/040_type_constraints
fhoxh at code2.0beta.co.uk
fhoxh at code2.0beta.co.uk
Mon Feb 16 03:22:48 GMT 2009
Author: fhoxh
Date: 2009-02-15 19:22:47 -0800 (Sun, 15 Feb 2009)
New Revision: 7705
Added:
Moose/branches/typeconstraint_intersection/lib/Moose/Meta/TypeCoercion/Intersection.pm
Moose/branches/typeconstraint_intersection/lib/Moose/Meta/TypeConstraint/Intersection.pm
Moose/branches/typeconstraint_intersection/t/040_type_constraints/034_intersection_types.t
Moose/branches/typeconstraint_intersection/t/040_type_constraints/035_subtyping_intersection_types.t
Modified:
Moose/branches/typeconstraint_intersection/lib/Moose.pm
Moose/branches/typeconstraint_intersection/lib/Moose/Util/TypeConstraints.pm
Moose/branches/typeconstraint_intersection/t/040_type_constraints/010_misc_type_tests.t
Moose/branches/typeconstraint_intersection/t/040_type_constraints/013_advanced_type_creation.t
Moose/branches/typeconstraint_intersection/t/040_type_constraints/014_type_notation_parser.t
Moose/branches/typeconstraint_intersection/t/040_type_constraints/026_normalize_type_name.t
Moose/branches/typeconstraint_intersection/t/040_type_constraints/032_throw_error.t
Log:
Simplistic implementation of type intersections, modeled after the implementation of type unions.
Added: Moose/branches/typeconstraint_intersection/lib/Moose/Meta/TypeCoercion/Intersection.pm
===================================================================
--- Moose/branches/typeconstraint_intersection/lib/Moose/Meta/TypeCoercion/Intersection.pm (rev 0)
+++ Moose/branches/typeconstraint_intersection/lib/Moose/Meta/TypeCoercion/Intersection.pm 2009-02-16 03:22:47 UTC (rev 7705)
@@ -0,0 +1,104 @@
+
+package Moose::Meta::TypeCoercion::Intersection;
+
+use strict;
+use warnings;
+use metaclass;
+
+use Scalar::Util 'blessed';
+
+our $VERSION = '0.70';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::TypeCoercion';
+
+sub compile_type_coercion {
+ my $self = shift;
+ my $type_constraint = $self->type_constraint;
+
+ (blessed $type_constraint && $type_constraint->isa('Moose::Meta::TypeConstraint::Intersection'))
+ || Moose->throw_error("You can only a Moose::Meta::TypeCoercion::Intersection for a " .
+ "Moose::Meta::TypeConstraint::Intersection, not a $type_constraint");
+
+ $self->_compiled_type_coercion(sub {
+ my $value = shift;
+ # go through all the type constraints
+ # in the intersection, and check em ...
+ foreach my $type (@{$type_constraint->type_constraints}) {
+ # if they have a coercion first
+ if ($type->has_coercion) {
+ # then try to coerce them ...
+ my $temp = $type->coerce($value);
+ # and if they get something
+ # make sure it still fits within
+ # the intersection type ...
+ return $temp if $type_constraint->check($temp);
+ }
+ }
+ return undef;
+ });
+}
+
+sub has_coercion_for_type { 0 }
+
+sub add_type_coercions {
+ Moose->throw_error("Cannot add additional type coercions to Intersection types");
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::TypeCoercion::Intersection - The Moose Type Coercion metaclass for intersections
+
+=head1 DESCRIPTION
+
+For the most part, the only time you will ever encounter an
+instance of this class is if you are doing some serious deep
+introspection. This API should not be considered final, but
+it is B<highly unlikely> that this will matter to a regular
+Moose user.
+
+If you wish to use features at this depth, please come to the
+#moose IRC channel on irc.perl.org and we can talk :)
+
+=head1 METHODS
+
+=over 4
+
+=item B<meta>
+
+=item B<compile_type_coercion>
+
+=item B<has_coercion_for_type>
+
+=item B<add_type_coercions>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt> and
+Adam Foxson E<lt>afoxson at pobox.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2009 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: Moose/branches/typeconstraint_intersection/lib/Moose/Meta/TypeConstraint/Intersection.pm
===================================================================
--- Moose/branches/typeconstraint_intersection/lib/Moose/Meta/TypeConstraint/Intersection.pm (rev 0)
+++ Moose/branches/typeconstraint_intersection/lib/Moose/Meta/TypeConstraint/Intersection.pm 2009-02-16 03:22:47 UTC (rev 7705)
@@ -0,0 +1,233 @@
+
+package Moose::Meta::TypeConstraint::Intersection;
+
+use strict;
+use warnings;
+use metaclass;
+
+use Moose::Meta::TypeCoercion::Intersection;
+
+our $VERSION = '0.70';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::TypeConstraint';
+
+__PACKAGE__->meta->add_attribute('type_constraints' => (
+ accessor => 'type_constraints',
+ default => sub { [] }
+));
+
+sub new {
+ my ($class, %options) = @_;
+ my $self = $class->SUPER::new(
+ name => (join '&' => sort {$a cmp $b}
+ map { $_->name } @{$options{type_constraints}}),
+ parent => undef,
+ message => undef,
+ hand_optimized_type_constraint => undef,
+ compiled_type_constraint => sub {
+ my $value = shift;
+ my $count = 0;
+ foreach my $type (@{$options{type_constraints}}) {
+ $count++ if $type->check($value);
+ }
+ return $count == scalar @{$options{type_constraints}} ? 1 : undef;
+ },
+ %options
+ );
+ $self->_set_constraint(sub { $self->check($_[0]) });
+ $self->coercion(Moose::Meta::TypeCoercion::Intersection->new(
+ type_constraint => $self
+ ));
+ return $self;
+}
+
+sub equals {
+ my ( $self, $type_or_name ) = @_;
+
+ my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+
+ return unless $other->isa(__PACKAGE__);
+
+ my @self_constraints = @{ $self->type_constraints };
+ my @other_constraints = @{ $other->type_constraints };
+
+ return unless @self_constraints == @other_constraints;
+
+ # FIXME presort type constraints for efficiency?
+ constraint: foreach my $constraint ( @self_constraints ) {
+ for ( my $i = 0; $i < @other_constraints; $i++ ) {
+ if ( $constraint->equals($other_constraints[$i]) ) {
+ splice @other_constraints, $i, 1;
+ next constraint;
+ }
+ }
+ }
+
+ return @other_constraints == 0;
+}
+
+sub parents {
+ my $self = shift;
+ $self->type_constraints;
+}
+
+sub validate {
+ my ($self, $value) = @_;
+ my $message;
+ foreach my $type (@{$self->type_constraints}) {
+ my $err = $type->validate($value);
+ return unless defined $err;
+ $message .= ($message ? ' and ' : '') . $err
+ if defined $err;
+ }
+ return ($message . ' in (' . $self->name . ')') ;
+}
+
+sub is_a_type_of {
+ my ($self, $type_name) = @_;
+ foreach my $type (@{$self->type_constraints}) {
+ return 1 if $type->is_a_type_of($type_name);
+ }
+ return 0;
+}
+
+sub is_subtype_of {
+ my ($self, $type_name) = @_;
+ foreach my $type (@{$self->type_constraints}) {
+ return 1 if $type->is_subtype_of($type_name);
+ }
+ return 0;
+}
+
+sub create_child_type {
+ my ( $self, %opts ) = @_;
+
+ my $constraint
+ = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
+
+ # if we have a type constraint intersection, and no
+ # type check, this means we are just aliasing
+ # the intersection constraint, which means we need to
+ # handle this differently.
+ # - SL
+ if ( not( defined $opts{constraint} )
+ && $self->has_coercion ) {
+ $constraint->coercion(
+ Moose::Meta::TypeCoercion::Intersection->new(
+ type_constraint => $self,
+ )
+ );
+ }
+
+ return $constraint;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::TypeConstraint::Intersection - An intersection of Moose type constraints
+
+=head1 DESCRIPTION
+
+This metaclass represents an intersection of Moose type constraints. More
+details to be explained later (possibly in a Cookbook recipe).
+
+This actually used to be part of Moose::Meta::TypeConstraint, but it
+is now better off in it's own file.
+
+=head1 METHODS
+
+This class is not a subclass of Moose::Meta::TypeConstraint,
+but it does provide the same API
+
+=over 4
+
+=item B<meta>
+
+=item B<new>
+
+=item B<name>
+
+=item B<type_constraints>
+
+=item B<parents>
+
+=item B<constraint>
+
+=item B<includes_type>
+
+=item B<equals>
+
+=back
+
+=head2 Overridden methods
+
+=over 4
+
+=item B<check>
+
+=item B<coerce>
+
+=item B<validate>
+
+=item B<is_a_type_of>
+
+=item B<is_subtype_of>
+
+=back
+
+=head2 Empty or Stub methods
+
+These methods tend to not be very relevant in
+the context of an intersection. Either that or they are
+just difficult to specify and not very useful
+anyway. They are here for completeness.
+
+=over 4
+
+=item B<parent>
+
+=item B<coercion>
+
+=item B<has_coercion>
+
+=item B<message>
+
+=item B<has_message>
+
+=item B<hand_optimized_type_constraint>
+
+=item B<has_hand_optimized_type_constraint>
+
+=item B<create_child_type>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt> and
+Adam Foxson E<lt>afoxson at pobox.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2009 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Modified: Moose/branches/typeconstraint_intersection/lib/Moose/Util/TypeConstraints.pm
===================================================================
--- Moose/branches/typeconstraint_intersection/lib/Moose/Util/TypeConstraints.pm 2009-02-15 16:54:59 UTC (rev 7704)
+++ Moose/branches/typeconstraint_intersection/lib/Moose/Util/TypeConstraints.pm 2009-02-16 03:22:47 UTC (rev 7705)
@@ -34,6 +34,7 @@
use Moose::Meta::TypeConstraint;
use Moose::Meta::TypeConstraint::Union;
+use Moose::Meta::TypeConstraint::Intersection;
use Moose::Meta::TypeConstraint::Parameterized;
use Moose::Meta::TypeConstraint::Parameterizable;
use Moose::Meta::TypeConstraint::Class;
@@ -41,6 +42,7 @@
use Moose::Meta::TypeConstraint::Enum;
use Moose::Meta::TypeCoercion;
use Moose::Meta::TypeCoercion::Union;
+use Moose::Meta::TypeCoercion::Intersection;
use Moose::Meta::TypeConstraint::Registry;
use Moose::Util::TypeConstraints::OptimizedConstraints;
@@ -97,6 +99,29 @@
);
}
+sub create_type_constraint_intersection {
+ my @type_constraint_names;
+
+ if (scalar @_ == 1 && _detect_type_constraint_intersection($_[0])) {
+ @type_constraint_names = _parse_type_constraint_intersection($_[0]);
+ }
+ else {
+ @type_constraint_names = @_;
+ }
+
+ (scalar @type_constraint_names >= 2)
+ || __PACKAGE__->_throw_error("You must pass in at least 2 type names to make an intersection");
+
+ my @type_constraints = map {
+ find_or_parse_type_constraint($_) ||
+ __PACKAGE__->_throw_error("Could not locate type constraint ($_) for the intersection");
+ } @type_constraint_names;
+
+ return Moose::Meta::TypeConstraint::Intersection->new(
+ type_constraints => \@type_constraints
+ );
+}
+
sub create_parameterized_type_constraint {
my $type_constraint_name = shift;
my ($base_type, $type_parameter) = _parse_parameterized_type_constraint($type_constraint_name);
@@ -209,6 +234,8 @@
if ($constraint = find_type_constraint($type_constraint_name)) {
return $constraint;
+ } elsif (_detect_type_constraint_intersection($type_constraint_name)) {
+ $constraint = create_type_constraint_intersection($type_constraint_name);
} elsif (_detect_type_constraint_union($type_constraint_name)) {
$constraint = create_type_constraint_union($type_constraint_name);
} elsif (_detect_parameterized_type_constraint($type_constraint_name)) {
@@ -455,8 +482,11 @@
my $op_union = qr{ \s* \| \s* }x;
my $union = qr{ $type (?: $op_union $type )+ }x;
- $any = qr{ $type | $union }x;
+ my $op_intersection = qr{ \s* & \s* }x;
+ my $intersection = qr{ $type (?: $op_intersection $type )+ }x;
+ $any = qr{ $type | $union | $intersection }x;
+
sub _parse_parameterized_type_constraint {
{ no warnings 'void'; $any; } # force capture of interpolated lexical
$_[0] =~ m{ $type_capture_parts }x;
@@ -484,10 +514,31 @@
@rv;
}
+ sub _parse_type_constraint_intersection {
+ { no warnings 'void'; $any; } # force capture of interpolated lexical
+ my $given = shift;
+ my @rv;
+ while ( $given =~ m{ \G (?: $op_intersection )? ($type) }gcx ) {
+ push @rv => $1;
+ }
+ (pos($given) eq length($given))
+ || __PACKAGE__->_throw_error("'$given' didn't parse (parse-pos="
+ . pos($given)
+ . " and str-length="
+ . length($given)
+ . ")");
+ @rv;
+ }
+
sub _detect_type_constraint_union {
{ no warnings 'void'; $any; } # force capture of interpolated lexical
$_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
}
+
+ sub _detect_type_constraint_intersection {
+ { no warnings 'void'; $any; } # force capture of interpolated lexical
+ $_[0] =~ m{^ $type $op_intersection $type ( $op_intersection .* )? $}x;
+ }
}
## --------------------------------------------------------
@@ -507,6 +558,7 @@
qw(
Moose::Meta::TypeConstraint
Moose::Meta::TypeConstraint::Union
+ Moose::Meta::TypeConstraint::Intersection
Moose::Meta::TypeConstraint::Parameterized
Moose::Meta::TypeConstraint::Parameterizable
Moose::Meta::TypeConstraint::Class
@@ -981,6 +1033,11 @@
Given string with C<$pipe_separated_types> or a list of C<@type_constraint_names>,
this will return a L<Moose::Meta::TypeConstraint::Union> instance.
+=item B<create_type_constraint_intersection ($pipe_separated_types | @type_constraint_names)>
+
+Given string with C<$pipe_separated_types> or a list of C<@type_constraint_names>,
+this will return a L<Moose::Meta::TypeConstraint::Intersection> instance.
+
=item B<create_parameterized_type_constraint ($type_name)>
Given a C<$type_name> in the form of:
@@ -1006,7 +1063,7 @@
This will attempt to find or create a type constraint given the a C<$type_name>.
If it cannot find it in the registry, it will see if it should be a union or
-container type an create one if appropriate
+intersection or container type an create one if appropriate
=item B<find_or_create_type_constraint ($type_name, ?$options_for_anon_type)>
Modified: Moose/branches/typeconstraint_intersection/lib/Moose.pm
===================================================================
--- Moose/branches/typeconstraint_intersection/lib/Moose.pm 2009-02-15 16:54:59 UTC (rev 7704)
+++ Moose/branches/typeconstraint_intersection/lib/Moose.pm 2009-02-16 03:22:47 UTC (rev 7705)
@@ -268,6 +268,7 @@
Moose::Meta::TypeCoercion
Moose::Meta::TypeCoercion::Union
+ Moose::Meta::TypeCoercion::Intersection
Moose::Meta::Method
Moose::Meta::Method::Accessor
Modified: Moose/branches/typeconstraint_intersection/t/040_type_constraints/010_misc_type_tests.t
===================================================================
--- Moose/branches/typeconstraint_intersection/t/040_type_constraints/010_misc_type_tests.t 2009-02-15 16:54:59 UTC (rev 7704)
+++ Moose/branches/typeconstraint_intersection/t/040_type_constraints/010_misc_type_tests.t 2009-02-16 03:22:47 UTC (rev 7705)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 8;
+use Test::More tests => 13;
use Test::Exception;
BEGIN {
@@ -22,6 +22,8 @@
# subtype with unions
{
+
+{
package Test::Moose::Meta::TypeConstraint::Union;
use overload '""' => sub {'Broken|Test'}, fallback => 1;
@@ -47,3 +49,38 @@
my $subtype2 = subtype 'New2' => as $subtype1;
ok $subtype2 => 'made a subtype of our subtype';
+
+}
+
+# subtype with intersections
+
+{
+
+{
+ package Test::Moose::Meta::TypeConstraint::Intersection;
+
+ use overload '""' => sub {'Broken&Test'}, fallback => 1;
+ use Moose;
+
+ extends 'Moose::Meta::TypeConstraint';
+}
+
+my $dummy_instance = Test::Moose::Meta::TypeConstraint::Intersection->new;
+
+ok $dummy_instance => "Created Instance";
+
+isa_ok $dummy_instance,
+ 'Test::Moose::Meta::TypeConstraint::Intersection' => 'isa correct type';
+
+is "$dummy_instance", "Broken&Test" =>
+ 'Got expected stringification result';
+
+my $subtype1 = subtype 'New1' => as $dummy_instance;
+
+ok $subtype1 => 'made a subtype from our type object';
+
+my $subtype2 = subtype 'New2' => as $subtype1;
+
+ok $subtype2 => 'made a subtype of our subtype';
+
+}
Modified: Moose/branches/typeconstraint_intersection/t/040_type_constraints/013_advanced_type_creation.t
===================================================================
--- Moose/branches/typeconstraint_intersection/t/040_type_constraints/013_advanced_type_creation.t 2009-02-15 16:54:59 UTC (rev 7704)
+++ Moose/branches/typeconstraint_intersection/t/040_type_constraints/013_advanced_type_creation.t 2009-02-16 03:22:47 UTC (rev 7705)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 33;
+use Test::More tests => 38;
use Test::Exception;
BEGIN {
@@ -55,6 +55,17 @@
ok(!$pure_insanity->check([ 1, {}, 'foo' ]), '... this didnt pass the type check');
ok(!$pure_insanity->check([ [], {}, 1 ]), '... this didnt pass the type check');
+# intersection of Arrays of Int | Str or Arrays of Str | Int
+
+my $sheer_insanity = Moose::Util::TypeConstraints::create_type_constraint_intersection('ArrayRef[Int|Str] & ArrayRef[Str | Int]');
+isa_ok($sheer_insanity, 'Moose::Meta::TypeConstraint::Intersection');
+
+ok($sheer_insanity->check([ 1, 4, 'foo' ]), '... this passed the type check');
+ok($sheer_insanity->check([ 1, 'Str', 'foo' ]), '... this passed the type check');
+
+ok(!$sheer_insanity->check([ 1, {}, 'foo' ]), '... this didnt pass the type check');
+ok(!$sheer_insanity->check([ [], {}, 1 ]), '... this didnt pass the type check');
+
## Nested Containers ...
# Array of Ints
Modified: Moose/branches/typeconstraint_intersection/t/040_type_constraints/014_type_notation_parser.t
===================================================================
--- Moose/branches/typeconstraint_intersection/t/040_type_constraints/014_type_notation_parser.t 2009-02-15 16:54:59 UTC (rev 7704)
+++ Moose/branches/typeconstraint_intersection/t/040_type_constraints/014_type_notation_parser.t 2009-02-16 03:22:47 UTC (rev 7705)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 41;
+use Test::More tests => 68;
BEGIN {
use_ok("Moose::Util::TypeConstraints");
@@ -103,3 +103,53 @@
'... this correctly split the union (' . $_ . ')'
) for keys %split_tests;
}
+
+## now for the intersections
+
+ok(Moose::Util::TypeConstraints::_detect_type_constraint_intersection($_),
+ '... this correctly detected intersection (' . $_ . ')')
+ for (
+ 'Int & Str',
+ 'Int&Str',
+ 'ArrayRef[Foo] & Int',
+ 'ArrayRef[Foo]&Int',
+ 'Int & ArrayRef[Foo]',
+ 'Int&ArrayRef[Foo]',
+ 'ArrayRef[Foo | Int] & Str',
+ 'ArrayRef[Foo|Int]&Str',
+ 'Str & ArrayRef[Foo | Int]',
+ 'Str&ArrayRef[Foo|Int]',
+ 'Some&Silly&Name&With&Pipes & Int',
+ 'Some&Silly&Name&With&Pipes&Int',
+);
+
+ok(!Moose::Util::TypeConstraints::_detect_type_constraint_intersection($_),
+ '... this correctly detected a non-intersection (' . $_ . ')')
+ for (
+ 'Int',
+ 'ArrayRef[Foo | Int]',
+ 'ArrayRef[Foo|Int]',
+);
+
+{
+ my %split_tests = (
+ 'Int & Str' => [ 'Int', 'Str' ],
+ 'Int&Str' => [ 'Int', 'Str' ],
+ 'ArrayRef[Foo] & Int' => [ 'ArrayRef[Foo]', 'Int' ],
+ 'ArrayRef[Foo]&Int' => [ 'ArrayRef[Foo]', 'Int' ],
+ 'Int & ArrayRef[Foo]' => [ 'Int', 'ArrayRef[Foo]' ],
+ 'Int&ArrayRef[Foo]' => [ 'Int', 'ArrayRef[Foo]' ],
+ 'ArrayRef[Foo | Int] & Str' => [ 'ArrayRef[Foo | Int]', 'Str' ],
+ 'ArrayRef[Foo|Int]&Str' => [ 'ArrayRef[Foo|Int]', 'Str' ],
+ 'Str & ArrayRef[Foo | Int]' => [ 'Str', 'ArrayRef[Foo | Int]' ],
+ 'Str&ArrayRef[Foo|Int]' => [ 'Str', 'ArrayRef[Foo|Int]' ],
+ 'Some&Silly&Name&With&Pipes & Int' => [ 'Some', 'Silly', 'Name', 'With', 'Pipes', 'Int' ],
+ 'Some&Silly&Name&With&Pipes&Int' => [ 'Some', 'Silly', 'Name', 'With', 'Pipes', 'Int' ],
+ );
+
+ is_deeply(
+ [ Moose::Util::TypeConstraints::_parse_type_constraint_intersection($_) ],
+ $split_tests{$_},
+ '... this correctly split the intersection (' . $_ . ')'
+ ) for keys %split_tests;
+}
Modified: Moose/branches/typeconstraint_intersection/t/040_type_constraints/026_normalize_type_name.t
===================================================================
--- Moose/branches/typeconstraint_intersection/t/040_type_constraints/026_normalize_type_name.t 2009-02-15 16:54:59 UTC (rev 7704)
+++ Moose/branches/typeconstraint_intersection/t/040_type_constraints/026_normalize_type_name.t 2009-02-16 03:22:47 UTC (rev 7705)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 37;
+use Test::More tests => 43;
use Test::Exception;
BEGIN {
@@ -149,3 +149,18 @@
is $union1->name, $union3->name, 'names match';
is $union2->name, $union3->name, 'names match';
+
+ok my $intersection1 = Moose::Util::TypeConstraints::create_type_constraint_intersection(
+ 'ArrayRef[Int|Str] & ArrayRef[Int | HashRef]') => 'Created Intersection1';
+
+ok my $intersection2 = Moose::Util::TypeConstraints::create_type_constraint_intersection(
+ 'ArrayRef[ Int|Str] & ArrayRef[Int | HashRef]') => 'Created Intersection2';
+
+ok my $intersection3 = Moose::Util::TypeConstraints::create_type_constraint_intersection(
+ 'ArrayRef[Int |Str ] & ArrayRef[Int | HashRef ]') => 'Created Intersection3';
+
+is $intersection1->name, $intersection2->name, 'names match';
+
+is $intersection1->name, $intersection3->name, 'names match';
+
+is $intersection2->name, $intersection3->name, 'names match';
Modified: Moose/branches/typeconstraint_intersection/t/040_type_constraints/032_throw_error.t
===================================================================
--- Moose/branches/typeconstraint_intersection/t/040_type_constraints/032_throw_error.t 2009-02-15 16:54:59 UTC (rev 7704)
+++ Moose/branches/typeconstraint_intersection/t/040_type_constraints/032_throw_error.t 2009-02-16 03:22:47 UTC (rev 7705)
@@ -1,7 +1,7 @@
use strict;
use warnings;
-use Test::More tests => 1;
+use Test::More tests => 2;
use Moose::Util::TypeConstraints;
@@ -10,3 +10,8 @@
like( $@, qr/\QYou must pass in at least 2 type names to make a union/,
'can throw a proper error without Moose being loaded by the caller' );
+
+eval { Moose::Util::TypeConstraints::create_type_constraint_intersection() };
+
+like( $@, qr/\QYou must pass in at least 2 type names to make an intersection/,
+ 'can throw a proper error without Moose being loaded by the caller' );
Added: Moose/branches/typeconstraint_intersection/t/040_type_constraints/034_intersection_types.t
===================================================================
--- Moose/branches/typeconstraint_intersection/t/040_type_constraints/034_intersection_types.t (rev 0)
+++ Moose/branches/typeconstraint_intersection/t/040_type_constraints/034_intersection_types.t 2009-02-16 03:22:47 UTC (rev 7705)
@@ -0,0 +1,73 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 34;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose::Util::TypeConstraints');
+}
+
+my $Str = find_type_constraint('Str');
+isa_ok($Str, 'Moose::Meta::TypeConstraint');
+
+my $Defined = find_type_constraint('Defined');
+isa_ok($Defined, 'Moose::Meta::TypeConstraint');
+
+ok(!$Str->check(undef), '... Str cannot accept an Undef value');
+ok($Str->check('String'), '... Str can accept an String value');
+ok($Defined->check('String'), '... Defined can accept an Str value');
+ok(!$Defined->check(undef), '... Defined cannot accept an undef value');
+
+my $Str_and_Defined = Moose::Meta::TypeConstraint::Intersection->new(type_constraints => [$Str, $Defined]);
+isa_ok($Str_and_Defined, 'Moose::Meta::TypeConstraint::Intersection');
+
+ok($Str_and_Defined->check(''), '... (Str & Defined) can accept a Defined value');
+ok($Str_and_Defined->check('String'), '... (Str & Defined) can accept a String value');
+ok(!$Str_and_Defined->check([]), '... (Str & Defined) cannot accept an array reference');
+
+ok($Str_and_Defined->is_a_type_of($Str), "subtype of Str");
+ok($Str_and_Defined->is_a_type_of($Defined), "subtype of Defined");
+
+ok( !$Str_and_Defined->equals($Str), "not equal to Str" );
+ok( $Str_and_Defined->equals($Str_and_Defined), "equal to self" );
+ok( $Str_and_Defined->equals(Moose::Meta::TypeConstraint::Intersection->new(type_constraints => [ $Str, $Defined ])), "equal to clone" );
+ok( $Str_and_Defined->equals(Moose::Meta::TypeConstraint::Intersection->new(type_constraints => [ $Defined, $Str ])), "equal to reversed clone" );
+
+ok( !$Str_and_Defined->is_a_type_of("ThisTypeDoesNotExist"), "not type of non existant type" );
+ok( !$Str_and_Defined->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of non existant type" );
+
+# another ....
+
+my $ArrayRef = find_type_constraint('ArrayRef');
+isa_ok($ArrayRef, 'Moose::Meta::TypeConstraint');
+
+my $Ref = find_type_constraint('Ref');
+isa_ok($Ref, 'Moose::Meta::TypeConstraint');
+
+ok($ArrayRef->check([]), '... ArrayRef can accept an [] value');
+ok(!$ArrayRef->check({}), '... ArrayRef cannot accept an {} value');
+ok($Ref->check({}), '... Ref can accept an {} value');
+ok(!$Ref->check(5), '... Ref cannot accept a 5 value');
+
+my $RefAndArray = Moose::Meta::TypeConstraint::Intersection->new(type_constraints => [$ArrayRef, $Ref]);
+isa_ok($RefAndArray, 'Moose::Meta::TypeConstraint::Intersection');
+
+ok($RefAndArray->check([]), '... (ArrayRef & Ref) can accept []');
+ok(!$RefAndArray->check({}), '... (ArrayRef & Ref) cannot accept {}');
+
+ok(!$RefAndArray->check(\(my $var1)), '... (ArrayRef & Ref) cannot accept scalar refs');
+ok(!$RefAndArray->check(sub {}), '... (ArrayRef & Ref) cannot accept code refs');
+ok(!$RefAndArray->check(50), '... (ArrayRef & Ref) cannot accept Numbers');
+
+diag $RefAndArray->validate([]);
+
+ok(!defined($RefAndArray->validate([])), '... (ArrayRef & Ref) can accept []');
+ok(defined($RefAndArray->validate(undef)), '... (ArrayRef & Ref) cannot accept undef');
+
+like($RefAndArray->validate(undef),
+qr/Validation failed for \'ArrayRef\' failed with value undef and Validation failed for \'Ref\' failed with value undef in \(ArrayRef&Ref\)/,
+'... (ArrayRef & Ref) cannot accept undef');
+
Property changes on: Moose/branches/typeconstraint_intersection/t/040_type_constraints/034_intersection_types.t
___________________________________________________________________
Name: svn:mime-type
+ text/plain
Added: Moose/branches/typeconstraint_intersection/t/040_type_constraints/035_subtyping_intersection_types.t
===================================================================
--- Moose/branches/typeconstraint_intersection/t/040_type_constraints/035_subtyping_intersection_types.t (rev 0)
+++ Moose/branches/typeconstraint_intersection/t/040_type_constraints/035_subtyping_intersection_types.t 2009-02-16 03:22:47 UTC (rev 7705)
@@ -0,0 +1,64 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 19;
+use Test::Exception;
+
+BEGIN {
+ use_ok("Moose::Util::TypeConstraints");
+}
+
+lives_ok {
+ subtype 'MyCollections' => as 'ArrayRef & Ref';
+} '... created the subtype special okay';
+
+{
+ my $t = find_type_constraint('MyCollections');
+ isa_ok($t, 'Moose::Meta::TypeConstraint');
+
+ is($t->name, 'MyCollections', '... name is correct');
+
+ my $p = $t->parent;
+ isa_ok($p, 'Moose::Meta::TypeConstraint::Intersection');
+ isa_ok($p, 'Moose::Meta::TypeConstraint');
+
+ is($p->name, 'ArrayRef&Ref', '... parent name is correct');
+
+ ok($t->check([]), '... validated it correctly');
+ ok(!$t->check(1), '... validated it correctly');
+}
+
+lives_ok {
+ subtype 'MyCollectionsExtended'
+ => as 'ArrayRef&Ref'
+ => where {
+ if (ref($_) eq 'ARRAY') {
+ return if scalar(@$_) < 2;
+ }
+ 1;
+ };
+} '... created the subtype special okay';
+
+{
+ my $t = find_type_constraint('MyCollectionsExtended');
+ isa_ok($t, 'Moose::Meta::TypeConstraint');
+
+ is($t->name, 'MyCollectionsExtended', '... name is correct');
+
+ my $p = $t->parent;
+ isa_ok($p, 'Moose::Meta::TypeConstraint::Intersection');
+ isa_ok($p, 'Moose::Meta::TypeConstraint');
+
+ is($p->name, 'ArrayRef&Ref', '... parent name is correct');
+
+ ok(!$t->check([]), '... validated it correctly');
+ ok($t->check([1, 2]), '... validated it correctly');
+
+ ok($t->check([ one => 1, two => 2 ]), '... validated it correctly');
+
+ ok(!$t->check(1), '... validated it correctly');
+}
+
+
Property changes on: Moose/branches/typeconstraint_intersection/t/040_type_constraints/035_subtyping_intersection_types.t
___________________________________________________________________
Name: svn:mime-type
+ text/plain
More information about the Moose-commits
mailing list