From 7556d3d549fae53d6cf4c0d1db4661f60f6dc32f Mon Sep 17 00:00:00 2001 From: Jens Berthold Date: Fri, 17 Sep 2021 23:05:39 +0200 Subject: [PATCH 1/3] Clarify argument syntax of _create_type_constraint_union() --- lib/Moose/Util/TypeConstraints.pm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 22153d636..1b3911247 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -74,21 +74,21 @@ 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 @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 ) From c459ebb6e2bd242d1ee2c4c70dc52f87fae59550 Mon Sep 17 00:00:00 2001 From: Jens Berthold Date: Fri, 17 Sep 2021 23:12:26 +0200 Subject: [PATCH 2/3] Create non-existing type constraints in find_or_parse_type_constraint() --- lib/Moose/Util/TypeConstraints.pm | 39 +++++++++++++++++++++---------- 1 file changed, 27 insertions(+), 12 deletions(-) diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 1b3911247..262bc1eba 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -243,20 +243,28 @@ 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; } @@ -268,7 +276,8 @@ sub find_or_parse_type_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 +1324,21 @@ L object for that enum name. Given a duck type name this function will create a new L 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 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 +1350,8 @@ global registry. =head3 find_or_create_does_type_constraint($type_name) -These functions will first call C. If -that function does not return a type, a new type object will -be created. +These functions will call C with the +C option so that a new type object will be created if necessary. The C variant will use C and the C variant will use C. From bc6abbab99a0e7b31056034e77432c725497f317 Mon Sep 17 00:00:00 2001 From: Jens Berthold Date: Fri, 17 Sep 2021 23:13:10 +0200 Subject: [PATCH 3/3] fix union types referencing with non-existent (non-Moose) types --- lib/Moose/Util/TypeConstraints.pm | 9 ++++-- .../attribute_type_unions_non_moose.t | 31 +++++++++++++++++++ 2 files changed, 38 insertions(+), 2 deletions(-) create mode 100644 t/attributes/attribute_type_unions_non_moose.t diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 262bc1eba..87195ee3a 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -80,7 +80,9 @@ sub create_named_type_constraint_union { sub _create_type_constraint_union { my ( $tcs, $options ) = @_; $options //= {}; + my $name = $options->{name}; + my $creator = $options->{creator}; my @type_constraint_names; @@ -95,7 +97,7 @@ sub _create_type_constraint_union { || 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; @@ -269,7 +271,10 @@ sub find_or_parse_type_constraint { 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 diff --git a/t/attributes/attribute_type_unions_non_moose.t b/t/attributes/attribute_type_unions_non_moose.t new file mode 100644 index 000000000..2dea693ef --- /dev/null +++ b/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;