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