lib/Moose/Meta/Method/Accessor/Native/Writer.pm

   1 package Moose::Meta::Method::Accessor::Native::Writer;
   2
   3 use strict;
   4 use warnings;
   5
   6 use List::MoreUtils qw( any );
   7
   8 our $VERSION = '1.19';
   9 $VERSION = eval $VERSION;
  10 our $AUTHORITY = 'cpan:STEVAN';
  11
  12 use Moose::Role;
  13
  14 with 'Moose::Meta::Method::Accessor::Native';
  15
  16 requires '_potential_value';
  17
  18 sub _generate_method {
  19     my $self = shift;
  20
  21     my $inv         = '$self';
  22     my $slot_access = $self->_get_value($inv);
  23
  24     return (
  25         'sub {',
  26             'my ' . $inv . ' = shift;',
  27             $self->_inline_curried_arguments,
  28             $self->_inline_writer_core($inv, $slot_access),
  29         '}',
  30     );
  31 }
  32
  33 sub _inline_writer_core {
  34     my $self = shift;
  35     my ($inv, $slot_access) = @_;
  36
  37     my $potential = $self->_potential_value($slot_access);
  38     my $old       = '@old';
  39
  40     my @code;
  41     push @code, (
  42         $self->_inline_check_argument_count,
  43         $self->_inline_process_arguments($inv, $slot_access),
  44         $self->_inline_check_arguments('for writer'),
  45         $self->_inline_check_lazy($inv),
  46     );
  47
  48     if ($self->_return_value($slot_access)) {
  49         # some writers will save the return value in this variable when they
  50         # generate the potential value.
  51         push @code, 'my @return;'
  52     }
  53
  54     push @code, (
  55         $self->_inline_coerce_new_values,
  56         $self->_inline_copy_native_value(\$potential),
  57         $self->_inline_tc_code($potential),
  58         $self->_inline_get_old_value_for_trigger($inv, $old),
  59         $self->_inline_capture_return_value($slot_access),
  60         $self->_inline_set_new_value($inv, $potential, $slot_access),
  61         $self->_inline_trigger($inv, $slot_access, $old),
  62         $self->_inline_return_value($slot_access, 'for writer'),
  63     );
  64
  65     return @code;
  66 }
  67
  68 sub _inline_process_arguments { return }
  69
  70 sub _inline_check_arguments { return }
  71
  72 sub _inline_coerce_new_values { return }
  73
  74 sub _writer_value_needs_copy {
  75     my $self = shift;
  76
  77     return $self->_constraint_must_be_checked;
  78 }
  79
  80 sub _constraint_must_be_checked {
  81     my $self = shift;
  82
  83     my $attr = $self->associated_attribute;
  84
  85     return $attr->has_type_constraint
  86         && (!$self->_is_root_type( $attr->type_constraint )
  87          || ( $attr->should_coerce && $attr->type_constraint->has_coercion)
  88            );
  89 }
  90
  91 sub _is_root_type {
  92     my $self = shift;
  93     my ($type) = @_;
  94
  95     my $name = $type->name;
  96
  97     return any { $name eq $_ } @{ $self->root_types };
  98 }
  99
 100 sub _inline_copy_native_value {
 101     my $self = shift;
 102     my ($potential_ref) = @_;
 103
 104     return unless $self->_writer_value_needs_copy;
 105
 106     my $code = 'my $potential = ' . ${$potential_ref} . ';';
 107
 108     ${$potential_ref} = '$potential';
 109
 110     return $code;
 111 }
 112
 113 around _inline_tc_code => sub {
 114     my $orig = shift;
 115     my $self = shift;
 116     my ($value, $for_lazy) = @_;
 117
 118     return unless $for_lazy || $self->_constraint_must_be_checked;
 119
 120     return $self->$orig(@_);
 121 };
 122
 123 sub _inline_check_coercion {
 124     my $self = shift;
 125     my ($value) = @_;
 126
 127     my $attr = $self->associated_attribute;
 128     return unless $attr->should_coerce && $attr->type_constraint->has_coercion;
 129
 130     # We want to break the aliasing in @_ in case the coercion tries to make a
 131     # destructive change to an array member.
 132     return $value . ' = $type_constraint_obj->coerce(' . $value . ');';
 133 }
 134
 135 around _inline_check_constraint => sub {
 136     my $orig = shift;
 137     my $self = shift;
 138     my ($value, $for_lazy) = @_;
 139
 140     return unless $for_lazy || $self->_constraint_must_be_checked;
 141
 142     return $self->$orig(@_);
 143 };
 144
 145 sub _inline_capture_return_value { return }
 146
 147 sub _inline_set_new_value {
 148     my $self = shift;
 149
 150     return $self->_inline_store_value(@_)
 151         if $self->_writer_value_needs_copy
 152         || !$self->_slot_access_can_be_inlined
 153         || !$self->_get_is_lvalue;
 154
 155     return $self->_inline_optimized_set_new_value(@_);
 156 }
 157
 158 sub _get_is_lvalue {
 159     my $self = shift;
 160
 161     return $self->associated_attribute->associated_class->instance_metaclass->inline_get_is_lvalue;
 162 }
 163
 164 sub _inline_optimized_set_new_value {
 165     my $self = shift;
 166
 167     return $self->_inline_store_value(@_);
 168 }
 169
 170 sub _return_value {
 171     my $self = shift;
 172     my ($slot_access) = @_;
 173
 174     return $slot_access;
 175 }
 176
 177 no Moose::Role;
 178
 179 1;