168 lines
4.6 KiB
Perl
168 lines
4.6 KiB
Perl
package Moose::Meta::Method::Accessor::Native::Collection;
|
|
our $VERSION = '2.2207';
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Moose::Role;
|
|
|
|
requires qw( _adds_members _new_members );
|
|
|
|
sub _inline_coerce_new_values {
|
|
my $self = shift;
|
|
|
|
return unless $self->associated_attribute->should_coerce;
|
|
|
|
return unless $self->_tc_member_type_can_coerce;
|
|
|
|
return (
|
|
'(' . $self->_new_members . ') = map { $member_coercion->($_) }',
|
|
$self->_new_members . ';',
|
|
);
|
|
}
|
|
|
|
sub _tc_member_type_can_coerce {
|
|
my $self = shift;
|
|
|
|
my $member_tc = $self->_tc_member_type;
|
|
|
|
return $member_tc && $member_tc->has_coercion;
|
|
}
|
|
|
|
sub _tc_member_type {
|
|
my $self = shift;
|
|
|
|
my $tc = $self->associated_attribute->type_constraint;
|
|
while ($tc) {
|
|
return $tc->type_parameter
|
|
if $tc->can('type_parameter');
|
|
$tc = $tc->parent;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub _writer_value_needs_copy {
|
|
my $self = shift;
|
|
|
|
return $self->_constraint_must_be_checked
|
|
&& !$self->_check_new_members_only;
|
|
}
|
|
|
|
sub _inline_tc_code {
|
|
my $self = shift;
|
|
my ($value, $tc, $coercion, $message, $is_lazy) = @_;
|
|
|
|
return unless $self->_constraint_must_be_checked;
|
|
|
|
if ($self->_check_new_members_only) {
|
|
return unless $self->_adds_members;
|
|
|
|
return $self->_inline_check_member_constraint($self->_new_members);
|
|
}
|
|
else {
|
|
return (
|
|
$self->_inline_check_coercion($value, $tc, $coercion, $is_lazy),
|
|
$self->_inline_check_constraint($value, $tc, $message, $is_lazy),
|
|
);
|
|
}
|
|
}
|
|
|
|
sub _check_new_members_only {
|
|
my $self = shift;
|
|
|
|
my $attr = $self->associated_attribute;
|
|
|
|
my $tc = $attr->type_constraint;
|
|
|
|
# If we have a coercion, we could come up with an entirely new value after
|
|
# coercing, so we need to check everything,
|
|
return 0 if $attr->should_coerce && $tc->has_coercion;
|
|
|
|
# If the parent is our root type (ArrayRef, HashRef, etc), that means we
|
|
# can just check the new members of the collection, because we know that
|
|
# we will always be generating an appropriate collection type.
|
|
#
|
|
# However, if this type has its own constraint (it's Parameteriz_able_,
|
|
# not Paramet_erized_), we don't know what is being checked by the
|
|
# constraint, so we need to check the whole value, not just the members.
|
|
return 1
|
|
if $self->_is_root_type( $tc->parent )
|
|
&& ( $tc->isa('Moose::Meta::TypeConstraint::Parameterized')
|
|
|| !$tc->can('parameterize') );
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub _inline_check_member_constraint {
|
|
my $self = shift;
|
|
my ($new_value) = @_;
|
|
|
|
my $attr_name = $self->associated_attribute->name;
|
|
|
|
my $check
|
|
= $self->_tc_member_type->can_be_inlined
|
|
? '! (' . $self->_tc_member_type->_inline_check('$new_val') . ')'
|
|
: ' !$member_tc->($new_val) ';
|
|
|
|
return (
|
|
'for my $new_val (' . $new_value . ') {',
|
|
"if ($check) {",
|
|
'my $msg = do { local $_ = $new_val; $member_message->($new_val) };'.
|
|
$self->_inline_throw_exception( ValidationFailedForInlineTypeConstraint =>
|
|
"attribute_name => '".$attr_name."',".
|
|
'type_constraint_message => $msg,'.
|
|
'class_name => $class_name,'.
|
|
'value => $new_val,'.
|
|
'new_member => 1',
|
|
) . ';',
|
|
'}',
|
|
'}',
|
|
);
|
|
}
|
|
|
|
sub _inline_get_old_value_for_trigger {
|
|
my $self = shift;
|
|
my ($instance, $old) = @_;
|
|
|
|
my $attr = $self->associated_attribute;
|
|
return unless $attr->has_trigger;
|
|
|
|
return (
|
|
'my ' . $old . ' = ' . $self->_has_value($instance),
|
|
'? ' . $self->_copy_old_value($self->_get_value($instance)),
|
|
': ();',
|
|
);
|
|
}
|
|
|
|
around _eval_environment => sub {
|
|
my $orig = shift;
|
|
my $self = shift;
|
|
|
|
my $env = $self->$orig(@_);
|
|
|
|
my $member_tc = $self->_tc_member_type;
|
|
|
|
return $env unless $member_tc;
|
|
|
|
$env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint );
|
|
$env->{'$member_coercion'} = \(
|
|
$member_tc->coercion->_compiled_type_coercion
|
|
) if $member_tc->has_coercion;
|
|
$env->{'$member_message'} = \(
|
|
$member_tc->has_message
|
|
? $member_tc->message
|
|
: $member_tc->_default_message
|
|
);
|
|
|
|
my $tc_env = $member_tc->inline_environment();
|
|
|
|
$env = { %{$env}, %{$tc_env} };
|
|
|
|
return $env;
|
|
};
|
|
|
|
no Moose::Role;
|
|
|
|
1;
|