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