lib/Moose/Meta/Method/Accessor/Native/Collection.pm

   1 package Moose::Meta::Method::Accessor::Native::Collection;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '1.25';
   7 $VERSION = eval $VERSION;
   8 our $AUTHORITY = 'cpan:STEVAN';
   9
  10 use Moose::Role;
  11
  12 requires qw( _adds_members );
  13
  14 around _inline_coerce_new_values => sub {
  15     shift;
  16     my $self = shift;
  17
  18     return q{} unless $self->associated_attribute->should_coerce;
  19
  20     return q{} unless $self->_tc_member_type_can_coerce;
  21
  22     return
  23           '('
  24         . $self->_new_members
  25         . ') = map { $member_tc_obj->coerce($_) } '
  26         . $self->_new_members . ';';
  27 };
  28
  29 sub _tc_member_type_can_coerce {
  30     my $self = shift;
  31
  32     my $member_tc = $self->_tc_member_type;
  33
  34     return $member_tc && $member_tc->has_coercion;
  35 }
  36
  37 sub _tc_member_type {
  38     my $self = shift;
  39
  40     for (
  41         my $tc = $self->associated_attribute->type_constraint;
  42         $tc;
  43         $tc = $tc->parent
  44         ) {
  45
  46         return $tc->type_parameter
  47             if $tc->can('type_parameter');
  48     }
  49
  50     return;
  51 }
  52
  53 around _value_needs_copy => sub {
  54     shift;
  55     my $self = shift;
  56
  57     return $self->_constraint_must_be_checked
  58         && !$self->_check_new_members_only;
  59 };
  60
  61 around _inline_tc_code => sub {
  62     shift;
  63     my ( $self, $potential_value ) = @_;
  64
  65     return q{} unless $self->_constraint_must_be_checked;
  66
  67     if ( $self->_check_new_members_only ) {
  68         return q{} unless $self->_adds_members;
  69
  70         return $self->_inline_check_member_constraint( $self->_new_members );
  71     }
  72     else {
  73         return $self->_inline_check_coercion($potential_value) . "\n"
  74             . $self->_inline_check_constraint($potential_value);
  75     }
  76 };
  77
  78 sub _check_new_members_only {
  79     my $self = shift;
  80
  81     my $attr = $self->associated_attribute;
  82
  83     my $tc = $attr->type_constraint;
  84
  85     # If we have a coercion, we could come up with an entirely new value after
  86     # coercing, so we need to check everything,
  87     return 0 if $attr->should_coerce && $tc->has_coercion;
  88
  89     # If the parent is our root type (ArrayRef, HashRef, etc), that means we
  90     # can just check the new members of the collection, because we know that
  91     # we will always be generating an appropriate collection type.
  92     #
  93     # However, if this type has its own constraint (it's Parameteriz_able_,
  94     # not Paramet_erized_), we don't know what is being checked by the
  95     # constraint, so we need to check the whole value, not just the members.
  96     return 1
  97         if $self->_is_root_type( $tc->parent )
  98             && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
  99
 100     return 0;
 101 }
 102
 103 sub _inline_check_member_constraint {
 104     my ( $self, $new_value ) = @_;
 105
 106     my $attr_name = $self->associated_attribute->name;
 107
 108     return '$member_tc->($_) || '
 109         . $self->_inline_throw_error(
 110         qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
 111             . ' . $member_tc_obj->get_message($_)',
 112         "data => \$_"
 113         ) . " for $new_value;";
 114 }
 115
 116 around _inline_get_old_value_for_trigger => sub {
 117     shift;
 118     my ( $self, $instance ) = @_;
 119
 120     my $attr = $self->associated_attribute;
 121     return '' unless $attr->has_trigger;
 122
 123     return
 124           'my @old = '
 125         . $self->_inline_has($instance) . q{ ? }
 126         . $self->_inline_copy_old_value( $self->_inline_get($instance) )
 127         . ": ();\n";
 128 };
 129
 130 around _eval_environment => sub {
 131     my $orig = shift;
 132     my $self = shift;
 133
 134     my $env = $self->$orig(@_);
 135
 136     my $member_tc = $self->_tc_member_type;
 137
 138     return $env unless $member_tc;
 139
 140     $env->{'$member_tc_obj'} = \($member_tc);
 141
 142     $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint );
 143
 144     return $env;
 145 };
 146
 147 no Moose::Role;
 148
 149 1;