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