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_coercion', '$type_message'),
  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_coercion', '$type_message'),
  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 sub _is_root_type {
  87     my $self = shift;
  88     my ($type) = @_;
  89
  90     my $name = $type->name;
  91
  92     return any { $name eq $_ } @{ $self->root_types };
  93 }
  94
  95 sub _inline_copy_native_value {
  96     my $self = shift;
  97     my ($potential_ref) = @_;
  98
  99     return unless $self->_writer_value_needs_copy;
 100
 101     my $code = 'my $potential = ' . ${$potential_ref} . ';';
 102
 103     ${$potential_ref} = '$potential';
 104
 105     return $code;
 106 }
 107
 108 around _inline_tc_code => sub {
 109     my $orig = shift;
 110     my $self = shift;
 111     my ($value, $tc, $coercion, $message, $for_lazy) = @_;
 112
 113     return unless $for_lazy || $self->_constraint_must_be_checked;
 114
 115     return $self->$orig(@_);
 116 };
 117
 118 around _inline_check_constraint => sub {
 119     my $orig = shift;
 120     my $self = shift;
 121     my ($value, $tc, $message, $for_lazy) = @_;
 122
 123     return unless $for_lazy || $self->_constraint_must_be_checked;
 124
 125     return $self->$orig(@_);
 126 };
 127
 128 sub _inline_capture_return_value { return }
 129
 130 sub _inline_set_new_value {
 131     my $self = shift;
 132
 133     return $self->_inline_store_value(@_)
 134         if $self->_writer_value_needs_copy
 135         || !$self->_slot_access_can_be_inlined
 136         || !$self->_get_is_lvalue;
 137
 138     return $self->_inline_optimized_set_new_value(@_);
 139 }
 140
 141 sub _get_is_lvalue {
 142     my $self = shift;
 143
 144     return $self->associated_attribute->associated_class->instance_metaclass->inline_get_is_lvalue;
 145 }
 146
 147 sub _inline_optimized_set_new_value {
 148     my $self = shift;
 149
 150     return $self->_inline_store_value(@_);
 151 }
 152
 153 sub _return_value {
 154     my $self = shift;
 155     my ($slot_access) = @_;
 156
 157     return $slot_access;
 158 }
 159
 160 no Moose::Role;
 161
 162 1;