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