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