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