Fix non-Moose union type constraints

lib/Moose/Util/TypeConstraints.pm

@@ -74,28 +74,30 @@ sub create_type_constraint_union {
 
 sub create_named_type_constraint_union {
     my $name = shift;
-    _create_type_constraint_union($name, \@_);
+    _create_type_constraint_union(\@_, { name => $name });
 }
 
 sub _create_type_constraint_union {
-    my $name;
-    $name = shift if @_ > 1;
-    my @tcs = @{ shift() };
+    my ( $tcs, $options ) = @_;
+    $options //= {};
+
+    my $name = $options->{name};
+    my $creator = $options->{creator};
 
     my @type_constraint_names;
 
-    if ( scalar @tcs == 1 && _detect_type_constraint_union( $tcs[0] ) ) {
-        @type_constraint_names = _parse_type_constraint_union( $tcs[0] );
+    if ( scalar @$tcs == 1 && _detect_type_constraint_union( $tcs->[0] ) ) {
+        @type_constraint_names = _parse_type_constraint_union( $tcs->[0] );
     }
     else {
-        @type_constraint_names = @tcs;
+        @type_constraint_names = @$tcs;
     }
 
     ( scalar @type_constraint_names >= 2 )
         || throw_exception("UnionTakesAtleastTwoTypeNames");
 
     my @type_constraints = map {
-        find_or_parse_type_constraint($_)
+        find_or_parse_type_constraint($_, $creator ? { creator => $creator } : ())
             || throw_exception( CouldNotLocateTypeConstraintForUnion => type_name => $_ );
     } @type_constraint_names;
 
@@ -243,32 +245,44 @@ sub find_or_create_type_constraint {
 
 sub find_or_create_isa_type_constraint {
     my ($type_constraint_name, $options) = @_;
-    find_or_parse_type_constraint($type_constraint_name)
-        || create_class_type_constraint($type_constraint_name, $options);
+    find_or_parse_type_constraint(
+        $type_constraint_name,
+        { creator => sub { create_class_type_constraint(shift, $options) } },
+    );
 }
 
 sub find_or_create_does_type_constraint {
     my ($type_constraint_name, $options) = @_;
-    find_or_parse_type_constraint($type_constraint_name)
-        || create_role_type_constraint($type_constraint_name, $options);
+    find_or_parse_type_constraint(
+        $type_constraint_name,
+        { creator => sub { create_role_type_constraint(shift, $options) } },
+    );
 }
 
 sub find_or_parse_type_constraint {
-    my $type_constraint_name = normalize_type_constraint_name(shift);
+    my ($tc, $options) = @_;
+    $options //= {};
     my $constraint;
 
+    my $type_constraint_name = normalize_type_constraint_name($tc);
+    my $creator = $options->{creator};
+
     if ( $constraint = find_type_constraint($type_constraint_name) ) {
         return $constraint;
     }
     elsif ( _detect_type_constraint_union($type_constraint_name) ) {
-        $constraint = create_type_constraint_union($type_constraint_name);
+        $constraint = _create_type_constraint_union(
+            [ $type_constraint_name ],
+            $creator ? { creator => $creator } : ()
+        );
     }
     elsif ( _detect_parameterized_type_constraint($type_constraint_name) ) {
         $constraint
             = create_parameterized_type_constraint($type_constraint_name);
     }
     else {
-        return;
+        return unless $creator;
+        return $creator->($type_constraint_name);
     }
 
     $REGISTRY->add_type_constraint($constraint);
@@ -1315,14 +1329,21 @@ L<Moose::Meta::TypeConstraint::Enum> object for that enum name.
 Given a duck type name this function will create a new
 L<Moose::Meta::TypeConstraint::DuckType> object for that enum name.
 
-=head3 find_or_parse_type_constraint($type_name)
+=head3 find_or_parse_type_constraint($type_name, ?$options)
 
 Given a type name, this first attempts to find a matching constraint
 in the global registry.
 
 If the type name is a union or parameterized type, it will create a
-new object of the appropriate, but if given a "regular" type that does
-not yet exist, it simply returns false.
+new object of the appropriate type. By default, if given a "regular"
+type that does not yet exist, it simply returns false. When given a
+function via C<creator> options it will pass the type name to
+that function and attempt to create it instead:
+
+  find_or_parse_type_constraint(
+      $type_constraint_name,
+      { creator => sub { create_class_type_constraint(shift, $opt) } },
+  );
 
 When given a union or parameterized type, the member or base type must
 already exist.
@@ -1334,9 +1355,8 @@ global registry.
 
 =head3 find_or_create_does_type_constraint($type_name)
 
-These functions will first call C<find_or_parse_type_constraint>. If
-that function does not return a type, a new type object will
-be created.
+These functions will call C<find_or_parse_type_constraint> with the
+C<creator> option so that a new type object will be created if necessary.
 
 The C<isa> variant will use C<create_class_type_constraint> and the
 C<does> variant will use C<create_role_type_constraint>.

t/attributes/attribute_type_unions_non_moose.t

@@ -0,0 +1,31 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+{
+    package TestAlgoAA;
+    sub new { return bless {}, shift }
+
+    package TestAlgoBB;
+    sub new { return bless {}, shift }
+
+    package Foo;
+    use Moose;
+
+    ::is( ::exception { has 'bar' => (is => 'rw', isa => 'TestAlgoAA | TestAlgoBB') }, undef, "can have union of non-Moose classes" );
+}
+
+my $foo = Foo->new;
+isa_ok($foo, 'Foo');
+
+is( exception {
+    $foo->bar(TestAlgoAA->new)
+}, undef, 'set bar successfully with unions\' first type' );
+
+is( exception {
+    $foo->bar(TestAlgoBB->new)
+}, undef, 'set bar successfully with unions\' second type' );
+
+done_testing;