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