lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm

   1 package Moose::Meta::Method::Accessor::Native::Hash::set;
   2
   3 use strict;
   4 use warnings;
   5
   6 use List::MoreUtils ();
   7 use Scalar::Util qw( looks_like_number );
   8
   9 use Moose::Role;
  10
  11 with 'Moose::Meta::Method::Accessor::Native::Hash::Writer' => {
  12     -excludes => [
  13         qw(
  14             _minimum_arguments
  15             _maximum_arguments
  16             _inline_process_arguments
  17             _inline_check_arguments
  18             _inline_coerce_new_values
  19             _inline_optimized_set_new_value
  20             _return_value
  21             )
  22     ],
  23 };
  24
  25 sub _minimum_arguments { 2 }
  26
  27 sub _maximum_arguments { undef }
  28
  29 around _inline_check_argument_count => sub {
  30     my $orig = shift;
  31     my $self = shift;
  32
  33     return (
  34         $self->$orig(@_),
  35         'if (@_ % 2) {',
  36             $self->_inline_throw_error(
  37                 '"You must pass an even number of arguments to set"',
  38             ) . ';',
  39         '}',
  40     );
  41 };
  42
  43 sub _inline_process_arguments {
  44     my $self = shift;
  45
  46     return (
  47         'my @keys_idx = grep { ! ($_ % 2) } 0..$#_;',
  48         'my @values_idx = grep { $_ % 2 } 0..$#_;',
  49     );
  50 }
  51
  52 sub _inline_check_arguments {
  53     my $self = shift;
  54
  55     return (
  56         'for (@keys_idx) {',
  57             'if (!defined($_[$_])) {',
  58                 $self->_inline_throw_error(
  59                     '"Hash keys passed to set must be defined"',
  60                 ) . ';',
  61             '}',
  62         '}',
  63     );
  64 }
  65
  66 sub _adds_members { 1 }
  67
  68 # We need to override this because while @_ can be written to, we cannot write
  69 # directly to $_[1].
  70 sub _inline_coerce_new_values {
  71     my $self = shift;
  72
  73     return unless $self->associated_attribute->should_coerce;
  74
  75     return unless $self->_tc_member_type_can_coerce;
  76
  77     # Is there a simpler way to do this?
  78     return (
  79         'my $iter = List::MoreUtils::natatime(2, @_);',
  80         '@_ = ();',
  81         'while (my ($key, $val) = $iter->()) {',
  82             'push @_, $key, $member_tc_obj->coerce($val);',
  83         '}',
  84     );
  85 };
  86
  87 sub _potential_value {
  88     my $self = shift;
  89     my ($slot_access) = @_;
  90
  91     return '{ %{ (' . $slot_access . ') }, @_ }';
  92 }
  93
  94 sub _new_members { '@_[ @values_idx ]' }
  95
  96 sub _inline_optimized_set_new_value {
  97     my $self = shift;
  98     my ($inv, $new, $slot_access) = @_;
  99
 100     return '@{ (' . $slot_access . ') }{ @_[@keys_idx] } = @_[@values_idx];';
 101 }
 102
 103 sub _return_value {
 104     my $self = shift;
 105     my ($slot_access) = @_;
 106
 107     return 'wantarray '
 108              . '? @{ (' . $slot_access . ') }{ @_[@keys_idx] } '
 109              . ': ' . $slot_access . '->{ $_[$keys_idx[0]] }';
 110 }
 111
 112 no Moose::Role;
 113
 114 1;