lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm

   1 package Moose::Meta::Method::Accessor::Native::Array::Writer;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '1.13';
   7 $VERSION = eval $VERSION;
   8 our $AUTHORITY = 'cpan:STEVAN';
   9
  10 use base 'Moose::Meta::Method::Accessor::Native::Array';
  11
  12 sub _generate_method {
  13     my $self = shift;
  14
  15     my $inv = '$self';
  16
  17     my $slot_access = $self->_inline_get($inv);
  18
  19     my $code = 'sub {';
  20     $code .= "\n" . $self->_inline_pre_body(@_);
  21
  22     $code .= "\n" . 'my $self = shift;';
  23
  24     $code .= "\n" . $self->_inline_check_lazy($inv);
  25
  26     $code .= "\n" . $self->_inline_curried_arguments;
  27
  28     $code .= "\n" . $self->_inline_check_argument_count;
  29
  30     $code .= "\n" . $self->_inline_process_arguments;
  31
  32     $code .= "\n" . $self->_inline_check_arguments;
  33
  34     my $new_values      = $self->_new_values($slot_access);
  35     my $potential_value = $self->_potential_value($slot_access);
  36
  37     if ( $self->_value_needs_copy ) {
  38         $code .= "\n" . "my \@potential = $potential_value;";
  39         $potential_value = '@potential';
  40     }
  41
  42     $code .= "\n"
  43         . $self->_inline_tc_code(
  44         $new_values,
  45         $potential_value
  46         );
  47
  48     $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv);
  49     $code .= "\n" . $self->_capture_old_value($slot_access);
  50
  51     $code .= "\n"
  52         . $self->_inline_store(
  53         $inv,
  54         $self->_value_needs_copy
  55         ? '\\' . $potential_value
  56         : '[' . $potential_value . ']'
  57         );
  58
  59     $code .= "\n" . $self->_inline_post_body(@_);
  60     $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' );
  61
  62     $code .= "\n" . $self->_return_value( $inv, '@old' );
  63
  64     $code .= "\n}";
  65
  66     return $code;
  67 }
  68
  69 sub _inline_process_arguments { q{} }
  70
  71 sub _inline_check_arguments { q{} }
  72
  73 sub _new_values { '@_' }
  74
  75 sub _value_needs_copy {
  76     my $self = shift;
  77
  78     return $self->_constraint_must_be_checked
  79         && !$self->_check_new_members_only;
  80 }
  81
  82 sub _inline_tc_code {
  83     my ( $self, $new_value, $potential_value ) = @_;
  84
  85     return q{} unless $self->_constraint_must_be_checked;
  86
  87     if ( $self->_check_new_members_only ) {
  88         return q{} unless $self->_adds_members;
  89
  90         return $self->_inline_check_member_constraint($new_value);
  91     }
  92     else {
  93         return $self->_inline_check_coercion( '\\' . $potential_value ) . "\n"
  94             . $self->_inline_check_constraint( '\\' . $potential_value );
  95     }
  96 }
  97
  98 sub _constraint_must_be_checked {
  99     my $self = shift;
 100
 101     my $attr = $self->associated_attribute;
 102
 103     return $attr->has_type_constraint
 104         && ( $attr->type_constraint->name ne 'ArrayRef'
 105         || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) );
 106 }
 107
 108 sub _check_new_members_only {
 109     my $self = shift;
 110
 111     my $attr = $self->associated_attribute;
 112
 113     my $tc = $attr->type_constraint;
 114
 115     # If we have a coercion, we could come up with an entirely new value after
 116     # coercing, so we need to check everything,
 117     return 0 if $attr->should_coerce && $tc->has_coercion;
 118
 119     # If the parent is ArrayRef, that means we can just check the new members
 120     # of the collection, because we know that we will always be generating an
 121     # ArrayRef. However, if this type has its own constraint, we don't know
 122     # what the constraint checks, so we need to check the whole value, not
 123     # just the members.
 124     return 1
 125         if $tc->parent->name eq 'ArrayRef'
 126             && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
 127
 128     return 0;
 129 }
 130
 131 sub _inline_check_member_constraint {
 132     my ( $self, $new_value ) = @_;
 133
 134     my $attr_name = $self->associated_attribute->name;
 135
 136     return '$member_tc->($_) || '
 137         . $self->_inline_throw_error(
 138         qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
 139             . ' . $member_tc->get_message($_)',
 140         "data => \$_"
 141         ) . " for $new_value;";
 142 }
 143
 144 sub _inline_check_coercion {
 145     my ( $self, $value ) = @_;
 146
 147     my $attr = $self->associated_attribute;
 148
 149     return ''
 150         unless $attr->should_coerce && $attr->type_constraint->has_coercion;
 151
 152     # We want to break the aliasing in @_ in case the coercion tries to make a
 153     # destructive change to an array member.
 154     my $code = 'my @copy = @{ $value }';
 155     return '@_ = @{ $attr->type_constraint->coerce(\@copy) };';
 156 }
 157
 158 sub _inline_check_constraint {
 159     my $self = shift;
 160
 161     return q{} unless $self->_constraint_must_be_checked;
 162
 163     return $self->SUPER::_inline_check_constraint( $_[0] );
 164 }
 165
 166 sub _capture_old_value { return q{} }
 167 sub _return_value { return q{} }
 168
 169 sub _eval_environment {
 170     my $self = shift;
 171
 172     my $env = $self->SUPER::_eval_environment;
 173
 174     return $env
 175         unless $self->_constraint_must_be_checked
 176             and $self->_check_new_members_only;
 177
 178     $env->{'$member_tc'}
 179         = \( $self->associated_attribute->type_constraint->type_parameter
 180             ->_compiled_type_constraint );
 181
 182     return $env;
 183 }
 184
 185 1;