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 _new_value {'@_'}
  16
  17 sub _value_needs_copy {
  18     my $self = shift;
  19
  20     return $self->_constraint_must_be_checked
  21         && !$self->_check_new_members_only;
  22 }
  23
  24 sub _inline_tc_code {
  25     my ( $self, $new_value, $potential_value ) = @_;
  26
  27     return q{} unless $self->_constraint_must_be_checked;
  28
  29     if ( $self->_check_new_members_only ) {
  30         return q{} unless $self->_adds_members;
  31
  32         return $self->_inline_check_member_constraint($new_value);
  33     }
  34     else {
  35         return $self->_inline_check_coercion($potential_value) . "\n"
  36             . $self->_inline_check_constraint($potential_value);
  37     }
  38 }
  39
  40 sub _check_new_members_only {
  41     my $self = shift;
  42
  43     my $attr = $self->associated_attribute;
  44
  45     my $tc = $attr->type_constraint;
  46
  47     # If we have a coercion, we could come up with an entirely new value after
  48     # coercing, so we need to check everything,
  49     return 0 if $attr->should_coerce && $tc->has_coercion;
  50
  51     # If the parent is ArrayRef, that means we can just check the new members
  52     # of the collection, because we know that we will always be generating an
  53     # ArrayRef. However, if this type has its own constraint, we don't know
  54     # what the constraint checks, so we need to check the whole value, not
  55     # just the members.
  56     return 1
  57         if $tc->parent->name eq 'ArrayRef'
  58             && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
  59
  60     return 0;
  61 }
  62
  63 sub _inline_check_member_constraint {
  64     my ( $self, $new_value ) = @_;
  65
  66     my $attr_name = $self->associated_attribute->name;
  67
  68     return '$member_tc->($_) || '
  69         . $self->_inline_throw_error(
  70         qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
  71             . ' . $member_tc->get_message($_)',
  72         "data => \$_"
  73         ) . " for $new_value;";
  74 }
  75
  76 sub _inline_check_constraint {
  77     my $self = shift;
  78
  79     return q{} unless $self->_constraint_must_be_checked;
  80
  81     return $self->SUPER::_inline_check_constraint( $_[0] );
  82 }
  83
  84 sub _inline_get_old_value_for_trigger {
  85     my ( $self, $instance ) = @_;
  86
  87     my $attr = $self->associated_attribute;
  88     return '' unless $attr->has_trigger;
  89
  90     my $mi = $attr->associated_class->get_meta_instance;
  91     my $pred = $mi->inline_is_slot_initialized( $instance, $attr->name );
  92
  93     return
  94           'my @old = '
  95         . $pred . q{ ? } . '[ @{'
  96         . $self->_inline_get($instance)
  97         . '} ] : ()' . ";\n";
  98 }
  99
 100 sub _eval_environment {
 101     my $self = shift;
 102
 103     my $env = $self->SUPER::_eval_environment;
 104
 105     return $env
 106         unless $self->_constraint_must_be_checked
 107             and $self->_check_new_members_only;
 108
 109     $env->{'$member_tc'}
 110         = \( $self->associated_attribute->type_constraint->type_parameter
 111             ->_compiled_type_constraint );
 112
 113     return $env;
 114 }
 115
 116 1;