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 qw(
  11     Moose::Meta::Method::Accessor::Native::Array
  12     Moose::Meta::Method::Accessor::Native::Writer
  13 );
  14
  15 sub _inline_process_arguments {q{}}
  16
  17 sub _inline_check_arguments {q{}}
  18
  19 sub _new_value {'@_'}
  20
  21 sub _inline_copy_value {
  22     my ( $self, $potential_ref ) = @_;
  23
  24     return q{} unless $self->_value_needs_copy;
  25
  26     my $code = "my \@potential = ${$potential_ref};";
  27
  28     ${$potential_ref} = '@potential';
  29
  30     return $code;
  31 }
  32
  33 sub _value_needs_copy {
  34     my $self = shift;
  35
  36     return $self->_constraint_must_be_checked
  37         && !$self->_check_new_members_only;
  38 }
  39
  40 sub _inline_tc_code {
  41     my ( $self, $new_value, $potential_value ) = @_;
  42
  43     return q{} unless $self->_constraint_must_be_checked;
  44
  45     if ( $self->_check_new_members_only ) {
  46         return q{} unless $self->_adds_members;
  47
  48         return $self->_inline_check_member_constraint($new_value);
  49     }
  50     else {
  51         return $self->_inline_check_coercion( '\\' . $potential_value ) . "\n"
  52             . $self->_inline_check_constraint( '\\' . $potential_value );
  53     }
  54 }
  55
  56 sub _constraint_must_be_checked {
  57     my $self = shift;
  58
  59     my $attr = $self->associated_attribute;
  60
  61     return $attr->has_type_constraint
  62         && ( $attr->type_constraint->name ne 'ArrayRef'
  63         || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) );
  64 }
  65
  66 sub _check_new_members_only {
  67     my $self = shift;
  68
  69     my $attr = $self->associated_attribute;
  70
  71     my $tc = $attr->type_constraint;
  72
  73     # If we have a coercion, we could come up with an entirely new value after
  74     # coercing, so we need to check everything,
  75     return 0 if $attr->should_coerce && $tc->has_coercion;
  76
  77     # If the parent is ArrayRef, that means we can just check the new members
  78     # of the collection, because we know that we will always be generating an
  79     # ArrayRef. However, if this type has its own constraint, we don't know
  80     # what the constraint checks, so we need to check the whole value, not
  81     # just the members.
  82     return 1
  83         if $tc->parent->name eq 'ArrayRef'
  84             && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
  85
  86     return 0;
  87 }
  88
  89 sub _inline_check_member_constraint {
  90     my ( $self, $new_value ) = @_;
  91
  92     my $attr_name = $self->associated_attribute->name;
  93
  94     return '$member_tc->($_) || '
  95         . $self->_inline_throw_error(
  96         qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
  97             . ' . $member_tc->get_message($_)',
  98         "data => \$_"
  99         ) . " for $new_value;";
 100 }
 101
 102 sub _inline_check_coercion {
 103     my ( $self, $value ) = @_;
 104
 105     my $attr = $self->associated_attribute;
 106
 107     return ''
 108         unless $attr->should_coerce && $attr->type_constraint->has_coercion;
 109
 110     # We want to break the aliasing in @_ in case the coercion tries to make a
 111     # destructive change to an array member.
 112     my $code = 'my @copy = @{ $value }';
 113     return '@_ = @{ $attr->type_constraint->coerce(\@copy) };';
 114 }
 115
 116 sub _inline_check_constraint {
 117     my $self = shift;
 118
 119     return q{} unless $self->_constraint_must_be_checked;
 120
 121     return $self->SUPER::_inline_check_constraint( $_[0] );
 122 }
 123
 124 sub _capture_old_value { return q{} }
 125
 126 sub _inline_set_new_value {
 127     my ( $self, $inv, $new ) = @_;
 128
 129     return $self->SUPER::_inline_store(
 130         $inv,
 131         $self->_value_needs_copy ? '\\' . $new : '[' . $new . ']'
 132     );
 133 }
 134
 135 sub _return_value      { return q{} }
 136
 137 sub _eval_environment {
 138     my $self = shift;
 139
 140     my $env = $self->SUPER::_eval_environment;
 141
 142     return $env
 143         unless $self->_constraint_must_be_checked
 144             and $self->_check_new_members_only;
 145
 146     $env->{'$member_tc'}
 147         = \( $self->associated_attribute->type_constraint->type_parameter
 148             ->_compiled_type_constraint );
 149
 150     return $env;
 151 }
 152
 153 1;