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