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