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