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             $self->_inline_pre_body(@_),
  27             'my ' . $inv . ' = shift;',
  28             $self->_inline_curried_arguments,
  29             $self->_inline_writer_core($inv, $slot_access),
  30             $self->_inline_post_body(@_),
  31         '}',
  32     );
  33 }
  34
  35 sub _inline_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
  93 sub _is_root_type {
  94     my $self = shift;
  95     my ($type) = @_;
  96
  97     my $name = $type->name;
  98
  99     return any { $name eq $_ } @{ $self->root_types };
 100 }
 101
 102 sub _inline_copy_native_value {
 103     my $self = shift;
 104     my ($potential_ref) = @_;
 105
 106     return unless $self->_value_needs_copy;
 107
 108     my $code = 'my $potential = ' . ${$potential_ref} . ';';
 109
 110     ${$potential_ref} = '$potential';
 111
 112     return $code;
 113 }
 114
 115 around _inline_tc_code => sub {
 116     my $orig = shift;
 117     my $self = shift;
 118     my ($value, $for_lazy) = @_;
 119
 120     return unless $for_lazy || $self->_constraint_must_be_checked;
 121
 122     return $self->$orig(@_);
 123 };
 124
 125 sub _inline_check_coercion {
 126     my $self = shift;
 127     my ($value) = @_;
 128
 129     my $attr = $self->associated_attribute;
 130     return unless $attr->should_coerce && $attr->type_constraint->has_coercion;
 131
 132     # We want to break the aliasing in @_ in case the coercion tries to make a
 133     # destructive change to an array member.
 134     return $value . ' = $type_constraint_obj->coerce(' . $value . ');';
 135 }
 136
 137 around _inline_check_constraint => sub {
 138     my $orig = shift;
 139     my $self = shift;
 140     my ($value, $for_lazy) = @_;
 141
 142     return unless $for_lazy || $self->_constraint_must_be_checked;
 143
 144     return $self->$orig(@_);
 145 };
 146
 147 sub _inline_capture_return_value { return }
 148
 149 sub _set_new_value {
 150     my $self = shift;
 151
 152     return $self->_store_value(@_)
 153         if $self->_value_needs_copy
 154         || !$self->_slot_access_can_be_inlined
 155         || !$self->_get_is_lvalue;
 156
 157     return $self->_optimized_set_new_value(@_);
 158 }
 159
 160 sub _inline_set_new_value {
 161     my $self = shift;
 162     return $self->_set_new_value(@_) . ';';
 163 }
 164
 165 sub _get_is_lvalue {
 166     my $self = shift;
 167
 168     return $self->associated_attribute->associated_class->instance_metaclass->inline_get_is_lvalue;
 169 }
 170
 171 sub _optimized_set_new_value {
 172     my $self = shift;
 173
 174     return $self->_store_value(@_);
 175 }
 176
 177 sub _return_value {
 178     my $self = shift;
 179     my ($slot_access) = @_;
 180
 181     return $slot_access;
 182 }
 183
 184 no Moose::Role;
 185
 186 1;