use strict;
use warnings;
-our $VERSION = '1.13';
+use List::MoreUtils qw( any );
+
+our $VERSION = '1.15';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use base 'Moose::Meta::Method::Accessor::Native';
+use Moose::Role;
+
+with 'Moose::Meta::Method::Accessor::Native';
+
+requires '_potential_value';
sub _generate_method {
my $self = shift;
$code .= "\n" . $self->_inline_check_lazy($inv);
- my $new_value = $self->_new_value($slot_access);
my $potential_value = $self->_potential_value($slot_access);
- $code .= "\n" . $self->_inline_copy_value( \$potential_value );
+ $code .= "\n" . $self->_inline_copy_native_value( \$potential_value );
$code .= "\n"
. $self->_inline_tc_code(
- $new_value,
$potential_value
);
$code .= "\n" . $self->_inline_get_old_value_for_trigger($inv);
- $code .= "\n" . $self->_capture_old_value($slot_access);
+ $code .= "\n" . $self->_inline_capture_return_value($slot_access);
$code .= "\n"
. $self->_inline_set_new_value(
$inv,
- $potential_value
- );
+ $potential_value,
+ $slot_access,
+ ) . ';';
$code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' );
- $code .= "\n" . $self->_return_value( $inv, '@old', 'for writer' );
+ $code .= "\n" . $self->_return_value( $slot_access, 'for writer' );
return $code;
}
sub _inline_check_arguments {q{}}
-sub _value_needs_copy {0}
+sub _value_needs_copy {
+ my $self = shift;
-sub _inline_tc_code {
- die '_inline_tc_code must be overridden by ' . ref $_[0];
+ return $self->_constraint_must_be_checked;
}
-sub _inline_check_coercion {
- die '_inline_check_coercion must be overridden by ' . ref $_[0];
+sub _constraint_must_be_checked {
+ my $self = shift;
+
+ my $attr = $self->associated_attribute;
+
+ return $attr->has_type_constraint
+ && ( !$self->_is_root_type( $attr->type_constraint )
+ || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) );
}
-sub _inline_check_constraint {
- my $self = shift;
+sub _is_root_type {
+ my ($self, $type) = @_;
+
+ my $name = $type->name();
+
+ return any { $name eq $_ } @{ $self->root_types };
+}
+
+sub _inline_copy_native_value {
+ my ( $self, $potential_ref ) = @_;
+
+ return q{} unless $self->_value_needs_copy;
+
+ my $code = "my \$potential = ${$potential_ref};";
+
+ ${$potential_ref} = '$potential';
+
+ return $code;
+}
+
+sub _inline_tc_code {
+ my ( $self, $potential_value ) = @_;
return q{} unless $self->_constraint_must_be_checked;
- return $self->SUPER::_inline_check_constraint( $_[0] );
+ return $self->_inline_check_coercion($potential_value) . "\n"
+ . $self->_inline_check_constraint($potential_value);
}
-sub _constraint_must_be_checked {
- die '_constraint_must_be_checked must be overridden by ' . ref $_[0];
+sub _inline_check_coercion {
+ my ( $self, $value ) = @_;
+
+ my $attr = $self->associated_attribute;
+
+ return ''
+ unless $attr->should_coerce && $attr->type_constraint->has_coercion;
+
+ # We want to break the aliasing in @_ in case the coercion tries to make a
+ # destructive change to an array member.
+ return "$value = \$type_constraint_obj->coerce($value);";
}
-sub _capture_old_value { return q{} }
+override _inline_check_constraint => sub {
+ my $self = shift;
+
+ return q{} unless $self->_constraint_must_be_checked;
+
+ return super();
+};
+
+sub _inline_capture_return_value { return q{} }
sub _inline_set_new_value {
my $self = shift;
- return $self->SUPER::_inline_store(@_);
+ return $self->_inline_store(@_)
+ if $self->_value_needs_copy || !$self->_slot_access_can_be_inlined;
+
+ return $self->_inline_optimized_set_new_value(@_);
+};
+
+sub _inline_optimized_set_new_value {
+ my $self = shift;
+
+ return $self->_inline_store(@_);
}
sub _return_value { return q{} }
+no Moose::Role;
+
1;