diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index 3239b5145..8407179d7 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -6,6 +6,29 @@ use warnings; use metaclass; use overload '0+' => sub { refaddr(shift) }, # id an object + '|' => sub { + + ## It's kind of ugly that we need to know about Union Types, but this + ## is needed for syntax compatibility. Maybe someday we'll all just do + ## Or[Str,Str,Int] + + my @args = @_[0,1]; ## arg 3 is special, see the overload docs. + my @tc = grep {blessed $_} map { + blessed $_ ? $_ : + Moose::Util::TypeConstraints::find_or_parse_type_constraint($_) + || __PACKAGE__->_throw_error( "$_ is not a type constraint") + } @args; + + ( scalar @tc == scalar @args) + || __PACKAGE__->_throw_error( + "one of your type constraints is bad. Passed: ". join(', ', @args) ." Got: ". join(', ', @tc)); + + ( scalar @tc >= 2 ) + || __PACKAGE__->_throw_error("You must pass in at least 2 type names to make a union"); + + my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc); + return Moose::Util::TypeConstraints::register_type_constraint($union); + }, '""' => sub { shift->name }, # stringify to tc name bool => sub { 1 }, fallback => 1; diff --git a/t/type_constraints/union_overload_or.t b/t/type_constraints/union_overload_or.t new file mode 100644 index 000000000..edabf5932 --- /dev/null +++ b/t/type_constraints/union_overload_or.t @@ -0,0 +1,56 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +{ + + package Duck; + use Moose; + + sub quack { } + +} + +{ + + package Swan; + use Moose; + + sub honk { } + +} + +{ + + package RubberDuck; + use Moose; + + sub quack { } + +} + + +use Moose::Util::TypeConstraints 'class_type'; + +my $union = class_type('Duck') | class_type('RubberDuck'); + +my $duck = Duck->new(); +my $rubber_duck = RubberDuck->new(); +my $swan = Swan->new(); + +my @domain_values = ( $duck, $rubber_duck ); +is( + exception { $union->assert_valid($_) }, + undef, + qq{Union accepts "$_".} +) for @domain_values; + +like( + exception { $union->assert_valid($swan) }, + qr/Validation failed for/, + qq{Union does not accept Swan.} +); +done_testing; +